Make GHC generics capable of handling unboxed types

This adds a data family (`URec`) and six data family instances (`UAddr`,
`UChar`, `UDouble`, `UFloat`, `UInt`, and `UWord`) which a `deriving
Generic(1)` clause will generate if it sees `Addr#`, `Char#`, `Double#`,
`Float#`, `Int#`, or `Word#`, respectively. The programmer can then
provide instances for these data family instances to provide custom
implementations for unboxed types, similar to how derived `Eq`, `Ord`,
and `Show` instances currently special-case unboxed types.

Fixes #10868.

Test Plan: ./validate

Reviewers: goldfire, dreixel, bgamari, austin, hvr, kosmikus

Reviewed By: dreixel, kosmikus

Subscribers: simonpj, thomie

Differential Revision: https://phabricator.haskell.org/D1239

GHC Trac Issues: #10868

13 files changed, 387 insertions, 69 deletions

diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs
index 10d8747b73..f1212a38f1 100644
--- a/compiler/prelude/PrelNames.hs
+++ b/compiler/prelude/PrelNames.hs
@@ -370,7 +370,9 @@ genericTyConNames = [
     compTyConName, rTyConName, pTyConName, dTyConName,
     cTyConName, sTyConName, rec0TyConName, par0TyConName,
     d1TyConName, c1TyConName, s1TyConName, noSelTyConName,
-    repTyConName, rep1TyConName
+    repTyConName, rep1TyConName, uRecTyConName,
+    uAddrTyConName, uCharTyConName, uDoubleTyConName,
+    uFloatTyConName, uIntTyConName, uWordTyConName
   ]
 
 {-
@@ -687,7 +689,11 @@ u1DataCon_RDR, par1DataCon_RDR, rec1DataCon_RDR,
   conName_RDR, conFixity_RDR, conIsRecord_RDR,
   noArityDataCon_RDR, arityDataCon_RDR, selName_RDR,
   prefixDataCon_RDR, infixDataCon_RDR, leftAssocDataCon_RDR,
-  rightAssocDataCon_RDR, notAssocDataCon_RDR :: RdrName
+  rightAssocDataCon_RDR, notAssocDataCon_RDR,
+  uAddrDataCon_RDR, uCharDataCon_RDR, uDoubleDataCon_RDR,
+  uFloatDataCon_RDR, uIntDataCon_RDR, uWordDataCon_RDR,
+  uAddrHash_RDR, uCharHash_RDR, uDoubleHash_RDR,
+  uFloatHash_RDR, uIntHash_RDR, uWordHash_RDR :: RdrName
 
 u1DataCon_RDR    = dataQual_RDR gHC_GENERICS (fsLit "U1")
 par1DataCon_RDR  = dataQual_RDR gHC_GENERICS (fsLit "Par1")
@@ -728,6 +734,19 @@ leftAssocDataCon_RDR  = dataQual_RDR gHC_GENERICS (fsLit "LeftAssociative")
 rightAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "RightAssociative")
 notAssocDataCon_RDR   = dataQual_RDR gHC_GENERICS (fsLit "NotAssociative")
 
+uAddrDataCon_RDR   = dataQual_RDR gHC_GENERICS (fsLit "UAddr")
+uCharDataCon_RDR   = dataQual_RDR gHC_GENERICS (fsLit "UChar")
+uDoubleDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UDouble")
+uFloatDataCon_RDR  = dataQual_RDR gHC_GENERICS (fsLit "UFloat")
+uIntDataCon_RDR    = dataQual_RDR gHC_GENERICS (fsLit "UInt")
+uWordDataCon_RDR   = dataQual_RDR gHC_GENERICS (fsLit "UWord")
+
+uAddrHash_RDR   = varQual_RDR gHC_GENERICS (fsLit "uAddr#")
+uCharHash_RDR   = varQual_RDR gHC_GENERICS (fsLit "uChar#")
+uDoubleHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uDouble#")
+uFloatHash_RDR  = varQual_RDR gHC_GENERICS (fsLit "uFloat#")
+uIntHash_RDR    = varQual_RDR gHC_GENERICS (fsLit "uInt#")
+uWordHash_RDR   = varQual_RDR gHC_GENERICS (fsLit "uWord#")
 
 fmap_RDR, pure_RDR, ap_RDR, foldable_foldr_RDR, foldMap_RDR,
     traverse_RDR, mempty_RDR, mappend_RDR :: RdrName
@@ -789,7 +808,9 @@ v1TyConName, u1TyConName, par1TyConName, rec1TyConName,
   compTyConName, rTyConName, pTyConName, dTyConName,
   cTyConName, sTyConName, rec0TyConName, par0TyConName,
   d1TyConName, c1TyConName, s1TyConName, noSelTyConName,
-  repTyConName, rep1TyConName :: Name
+  repTyConName, rep1TyConName, uRecTyConName,
+  uAddrTyConName, uCharTyConName, uDoubleTyConName,
+  uFloatTyConName, uIntTyConName, uWordTyConName :: Name
 
 v1TyConName  = tcQual gHC_GENERICS (fsLit "V1") v1TyConKey
 u1TyConName  = tcQual gHC_GENERICS (fsLit "U1") u1TyConKey
@@ -818,6 +839,14 @@ noSelTyConName = tcQual gHC_GENERICS (fsLit "NoSelector") noSelTyConKey
 repTyConName  = tcQual gHC_GENERICS (fsLit "Rep")  repTyConKey
 rep1TyConName = tcQual gHC_GENERICS (fsLit "Rep1") rep1TyConKey
 
+uRecTyConName      = tcQual gHC_GENERICS (fsLit "URec") uRecTyConKey
+uAddrTyConName     = tcQual gHC_GENERICS (fsLit "UAddr") uAddrTyConKey
+uCharTyConName     = tcQual gHC_GENERICS (fsLit "UChar") uCharTyConKey
+uDoubleTyConName   = tcQual gHC_GENERICS (fsLit "UDouble") uDoubleTyConKey
+uFloatTyConName    = tcQual gHC_GENERICS (fsLit "UFloat") uFloatTyConKey
+uIntTyConName      = tcQual gHC_GENERICS (fsLit "UInt") uIntTyConKey
+uWordTyConName     = tcQual gHC_GENERICS (fsLit "UWord") uWordTyConKey
+
 -- Base strings Strings
 unpackCStringName, unpackCStringFoldrName,
     unpackCStringUtf8Name, eqStringName, stringTyConName :: Name
@@ -1469,7 +1498,9 @@ v1TyConKey, u1TyConKey, par1TyConKey, rec1TyConKey,
   compTyConKey, rTyConKey, pTyConKey, dTyConKey,
   cTyConKey, sTyConKey, rec0TyConKey, par0TyConKey,
   d1TyConKey, c1TyConKey, s1TyConKey, noSelTyConKey,
-  repTyConKey, rep1TyConKey :: Unique
+  repTyConKey, rep1TyConKey, uRecTyConKey,
+  uAddrTyConKey, uCharTyConKey, uDoubleTyConKey,
+  uFloatTyConKey, uIntTyConKey, uWordTyConKey :: Unique
 
 v1TyConKey    = mkPreludeTyConUnique 135
 u1TyConKey    = mkPreludeTyConUnique 136
@@ -1498,21 +1529,29 @@ noSelTyConKey = mkPreludeTyConUnique 154
 repTyConKey  = mkPreludeTyConUnique 155
 rep1TyConKey = mkPreludeTyConUnique 156
 
+uRecTyConKey    = mkPreludeTyConUnique 157
+uAddrTyConKey   = mkPreludeTyConUnique 158
+uCharTyConKey   = mkPreludeTyConUnique 159
+uDoubleTyConKey = mkPreludeTyConUnique 160
+uFloatTyConKey  = mkPreludeTyConUnique 161
+uIntTyConKey    = mkPreludeTyConUnique 162
+uWordTyConKey   = mkPreludeTyConUnique 163
+
 -- Type-level naturals
 typeNatKindConNameKey, typeSymbolKindConNameKey,
   typeNatAddTyFamNameKey, typeNatMulTyFamNameKey, typeNatExpTyFamNameKey,
   typeNatLeqTyFamNameKey, typeNatSubTyFamNameKey
   , typeSymbolCmpTyFamNameKey, typeNatCmpTyFamNameKey
   :: Unique
-typeNatKindConNameKey     = mkPreludeTyConUnique 160
-typeSymbolKindConNameKey  = mkPreludeTyConUnique 161
-typeNatAddTyFamNameKey    = mkPreludeTyConUnique 162
-typeNatMulTyFamNameKey    = mkPreludeTyConUnique 163
-typeNatExpTyFamNameKey    = mkPreludeTyConUnique 164
-typeNatLeqTyFamNameKey    = mkPreludeTyConUnique 165
-typeNatSubTyFamNameKey    = mkPreludeTyConUnique 166
-typeSymbolCmpTyFamNameKey = mkPreludeTyConUnique 167
-typeNatCmpTyFamNameKey    = mkPreludeTyConUnique 168
+typeNatKindConNameKey     = mkPreludeTyConUnique 164
+typeSymbolKindConNameKey  = mkPreludeTyConUnique 165
+typeNatAddTyFamNameKey    = mkPreludeTyConUnique 166
+typeNatMulTyFamNameKey    = mkPreludeTyConUnique 167
+typeNatExpTyFamNameKey    = mkPreludeTyConUnique 168
+typeNatLeqTyFamNameKey    = mkPreludeTyConUnique 169
+typeNatSubTyFamNameKey    = mkPreludeTyConUnique 170
+typeSymbolCmpTyFamNameKey = mkPreludeTyConUnique 171
+typeNatCmpTyFamNameKey    = mkPreludeTyConUnique 172
 
 ntTyConKey:: Unique
 ntTyConKey = mkPreludeTyConUnique 174
diff --git a/compiler/typecheck/TcGenGenerics.hs b/compiler/typecheck/TcGenGenerics.hs
index 6ea541c384..9a2b988b9f 100644
--- a/compiler/typecheck/TcGenGenerics.hs
+++ b/compiler/typecheck/TcGenGenerics.hs
@@ -30,6 +30,7 @@ import IfaceEnv         ( newGlobalBinder )
 import Name      hiding ( varName )
 import RdrName
 import BasicTypes
+import TysPrim
 import TysWiredIn
 import PrelNames
 import InstEnv
@@ -47,6 +48,7 @@ import FastString
 import Util
 
 import Control.Monad (mplus,forM)
+import Data.Maybe (isJust)
 
 #include "HsVersions.h"
 
@@ -278,14 +280,19 @@ canDoGenerics tc tc_args
         -- it relies on instantiating *polymorphic* sum and product types
         -- at the argument types of the constructors
     bad_con dc = if (any bad_arg_type (dataConOrigArgTys dc))
-                  then (NotValid (ppr dc <+> text "must not have unlifted or polymorphic arguments"))
+                  then (NotValid (ppr dc <+> text
+                    "must not have exotic unlifted or polymorphic arguments"))
                   else (if (not (isVanillaDataCon dc))
                           then (NotValid (ppr dc <+> text "must be a vanilla data constructor"))
                           else IsValid)
 
         -- Nor can we do the job if it's an existential data constructor,
         -- Nor if the args are polymorphic types (I don't think)
-    bad_arg_type ty = isUnLiftedType ty || not (isTauTy ty)
+    bad_arg_type ty = (isUnLiftedType ty && not (allowedUnliftedTy ty))
+                      || not (isTauTy ty)
+
+allowedUnliftedTy :: Type -> Bool
+allowedUnliftedTy = isJust . unboxedRepRDRs
 
 mergeErrors :: [Validity] -> Validity
 mergeErrors []             = IsValid
@@ -586,23 +593,29 @@ tc_mkRepTy ::  -- Gen0_ or Gen1_, for Rep or Rep1
             -> TcM Type
 tc_mkRepTy gk_ tycon metaDts =
   do
-    d1    <- tcLookupTyCon d1TyConName
-    c1    <- tcLookupTyCon c1TyConName
-    s1    <- tcLookupTyCon s1TyConName
-    nS1   <- tcLookupTyCon noSelTyConName
-    rec0  <- tcLookupTyCon rec0TyConName
-    rec1  <- tcLookupTyCon rec1TyConName
-    par1  <- tcLookupTyCon par1TyConName
-    u1    <- tcLookupTyCon u1TyConName
-    v1    <- tcLookupTyCon v1TyConName
-    plus  <- tcLookupTyCon sumTyConName
-    times <- tcLookupTyCon prodTyConName
-    comp  <- tcLookupTyCon compTyConName
+    d1      <- tcLookupTyCon d1TyConName
+    c1      <- tcLookupTyCon c1TyConName
+    s1      <- tcLookupTyCon s1TyConName
+    nS1     <- tcLookupTyCon noSelTyConName
+    rec0    <- tcLookupTyCon rec0TyConName
+    rec1    <- tcLookupTyCon rec1TyConName
+    par1    <- tcLookupTyCon par1TyConName
+    u1      <- tcLookupTyCon u1TyConName
+    v1      <- tcLookupTyCon v1TyConName
+    plus    <- tcLookupTyCon sumTyConName
+    times   <- tcLookupTyCon prodTyConName
+    comp    <- tcLookupTyCon compTyConName
+    uAddr   <- tcLookupTyCon uAddrTyConName
+    uChar   <- tcLookupTyCon uCharTyConName
+    uDouble <- tcLookupTyCon uDoubleTyConName
+    uFloat  <- tcLookupTyCon uFloatTyConName
+    uInt    <- tcLookupTyCon uIntTyConName
+    uWord   <- tcLookupTyCon uWordTyConName
 
     let mkSum' a b = mkTyConApp plus  [a,b]
         mkProd a b = mkTyConApp times [a,b]
         mkComp a b = mkTyConApp comp  [a,b]
-        mkRec0 a   = mkTyConApp rec0  [a]
+        mkRec0 a   = mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 a
         mkRec1 a   = mkTyConApp rec1  [a]
         mkPar1     = mkTyConTy  par1
         mkD    a   = mkTyConApp d1    [metaDTyCon, sumP (tyConDataCons a)]
@@ -650,6 +663,28 @@ tc_mkRepTy gk_ tycon metaDts =
 
     return (mkD tycon)
 
+-- Given the TyCons for each URec-related type synonym, check to see if the
+-- given type is an unlifted type that generics understands. If so, return
+-- its representation type. Otherwise, return Rec0.
+-- See Note [Generics and unlifted types]
+mkBoxTy :: TyCon -- UAddr
+        -> TyCon -- UChar
+        -> TyCon -- UDouble
+        -> TyCon -- UFloat
+        -> TyCon -- UInt
+        -> TyCon -- UWord
+        -> TyCon -- Rec0
+        -> Type
+        -> Type
+mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 ty
+  | ty == addrPrimTy   = mkTyConTy uAddr
+  | ty == charPrimTy   = mkTyConTy uChar
+  | ty == doublePrimTy = mkTyConTy uDouble
+  | ty == floatPrimTy  = mkTyConTy uFloat
+  | ty == intPrimTy    = mkTyConTy uInt
+  | ty == wordPrimTy   = mkTyConTy uWord
+  | otherwise          = mkTyConApp rec0 [ty]
+
 --------------------------------------------------------------------------------
 -- Meta-information
 --------------------------------------------------------------------------------
@@ -781,22 +816,22 @@ mk1Sum gk_ us i n datacon = (from_alt, to_alt)
     from_alt     = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs)
     from_alt_rhs = mkM1_E (genLR_E i n (mkProd_E gk_ us' datacon_varTys))
 
-    to_alt     = (mkM1_P (genLR_P i n (mkProd_P gk us' datacon_vars)), to_alt_rhs)
-                 -- These M1s are meta-information for the datatype
+    to_alt     = ( mkM1_P (genLR_P i n (mkProd_P gk us' datacon_varTys))
+                 , to_alt_rhs
+                 ) -- These M1s are meta-information for the datatype
     to_alt_rhs = case gk_ of
       Gen0_DC        -> nlHsVarApps datacon_rdr datacon_vars
       Gen1_DC argVar -> nlHsApps datacon_rdr $ map argTo datacon_varTys
         where
           argTo (var, ty) = converter ty `nlHsApp` nlHsVar var where
             converter = argTyFold argVar $ ArgTyAlg
-              {ata_rec0 = const $ nlHsVar unK1_RDR,
+              {ata_rec0 = nlHsVar . unboxRepRDR,
                ata_par1 = nlHsVar unPar1_RDR,
                ata_rec1 = const $ nlHsVar unRec1_RDR,
                ata_comp = \_ cnv -> (nlHsVar fmap_RDR `nlHsApp` cnv)
                                     `nlHsCompose` nlHsVar unComp1_RDR}
 
 
-
 -- Generates the L1/R1 sum pattern
 genLR_P :: Int -> Int -> LPat RdrName -> LPat RdrName
 genLR_P i n p
@@ -832,35 +867,54 @@ mkProd_E gk_ _ varTys = mkM1_E (foldBal prod appVars)
     prod a b = prodDataCon_RDR `nlHsApps` [a,b]
 
 wrapArg_E :: GenericKind_DC -> (RdrName, Type) -> LHsExpr RdrName
-wrapArg_E Gen0_DC          (var, _)  = mkM1_E (k1DataCon_RDR `nlHsVarApps` [var])
+wrapArg_E Gen0_DC          (var, ty) = mkM1_E $
+                            boxRepRDR ty `nlHsVarApps` [var]
                          -- This M1 is meta-information for the selector
-wrapArg_E (Gen1_DC argVar) (var, ty) = mkM1_E $ converter ty `nlHsApp` nlHsVar var
+wrapArg_E (Gen1_DC argVar) (var, ty) = mkM1_E $
+                            converter ty `nlHsApp` nlHsVar var
                          -- This M1 is meta-information for the selector
   where converter = argTyFold argVar $ ArgTyAlg
-          {ata_rec0 = const $ nlHsVar k1DataCon_RDR,
+          {ata_rec0 = nlHsVar . boxRepRDR,
            ata_par1 = nlHsVar par1DataCon_RDR,
            ata_rec1 = const $ nlHsVar rec1DataCon_RDR,
            ata_comp = \_ cnv -> nlHsVar comp1DataCon_RDR `nlHsCompose`
                                   (nlHsVar fmap_RDR `nlHsApp` cnv)}
 
+boxRepRDR :: Type -> RdrName
+boxRepRDR = maybe k1DataCon_RDR fst . unboxedRepRDRs
+
+unboxRepRDR :: Type -> RdrName
+unboxRepRDR = maybe unK1_RDR snd . unboxedRepRDRs
 
+-- Retrieve the RDRs associated with each URec data family instance
+-- constructor. See Note [Generics and unlifted types]
+unboxedRepRDRs :: Type -> Maybe (RdrName, RdrName)
+unboxedRepRDRs ty
+  | ty == addrPrimTy   = Just (uAddrDataCon_RDR,   uAddrHash_RDR)
+  | ty == charPrimTy   = Just (uCharDataCon_RDR,   uCharHash_RDR)
+  | ty == doublePrimTy = Just (uDoubleDataCon_RDR, uDoubleHash_RDR)
+  | ty == floatPrimTy  = Just (uFloatDataCon_RDR,  uFloatHash_RDR)
+  | ty == intPrimTy    = Just (uIntDataCon_RDR,    uIntHash_RDR)
+  | ty == wordPrimTy   = Just (uWordDataCon_RDR,   uWordHash_RDR)
+  | otherwise          = Nothing
 
 -- Build a product pattern
-mkProd_P :: GenericKind   -- Gen0 or Gen1
-         -> US                  -- Base for unique names
-               -> [RdrName]     -- List of variables to match
-               -> LPat RdrName  -- Resulting product pattern
-mkProd_P _  _ []   = mkM1_P (nlNullaryConPat u1DataCon_RDR)
-mkProd_P gk _ vars = mkM1_P (foldBal prod appVars)
+mkProd_P :: GenericKind       -- Gen0 or Gen1
+         -> US                -- Base for unique names
+         -> [(RdrName, Type)] -- List of variables to match,
+                              --   along with their types
+         -> LPat RdrName      -- Resulting product pattern
+mkProd_P _  _ []     = mkM1_P (nlNullaryConPat u1DataCon_RDR)
+mkProd_P gk _ varTys = mkM1_P (foldBal prod appVars)
                      -- These M1s are meta-information for the constructor
   where
-    appVars = map (wrapArg_P gk) vars
+    appVars = unzipWith (wrapArg_P gk) varTys
     prod a b = prodDataCon_RDR `nlConPat` [a,b]
 
-wrapArg_P :: GenericKind -> RdrName -> LPat RdrName
-wrapArg_P Gen0 v = mkM1_P (k1DataCon_RDR `nlConVarPat` [v])
+wrapArg_P :: GenericKind -> RdrName -> Type -> LPat RdrName
+wrapArg_P Gen0 v ty = mkM1_P (boxRepRDR ty `nlConVarPat` [v])
                    -- This M1 is meta-information for the selector
-wrapArg_P Gen1 v = m1DataCon_RDR `nlConVarPat` [v]
+wrapArg_P Gen1 v _  = m1DataCon_RDR `nlConVarPat` [v]
 
 mkGenericLocal :: US -> RdrName
 mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u))
@@ -883,3 +937,17 @@ foldBal' _  x []  = x
 foldBal' _  _ [y] = y
 foldBal' op x l   = let (a,b) = splitAt (length l `div` 2) l
                     in foldBal' op x a `op` foldBal' op x b
+
+{-
+Note [Generics and unlifted types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Normally, all constants are marked with K1/Rec0. The exception to this rule is
+when a data constructor has an unlifted argument (e.g., Int#, Char#, etc.). In
+that case, we must use a data family instance of URec (from GHC.Generics) to
+mark it. As a result, before we can generate K1 or unK1, we must first check
+to see if the type is actually one of the unlifted types for which URec has a
+data family instance; if so, we generate that instead.
+
+See wiki:Commentary/Compiler/GenericDeriving#Handlingunliftedtypes for more
+details on why URec is implemented the way it is.
+-}
diff --git a/docs/users_guide/7.12.1-notes.rst b/docs/users_guide/7.12.1-notes.rst
index 188daa9217..dc87c59c9e 100644
--- a/docs/users_guide/7.12.1-notes.rst
+++ b/docs/users_guide/7.12.1-notes.rst
@@ -74,6 +74,9 @@ Language
 -  Due to a :ghc-ticket:`security issue <10826>`, Safe Haskell now forbids
    annotations in programs marked as ``-XSafe``.
 
+-  Generic instances can be derived for data types whose constructors have
+   arguments with certain unlifted types. See :ref:`generic-programming` for
+   more details.
 
 Compiler
 ~~~~~~~~
diff --git a/docs/users_guide/glasgow_exts.rst b/docs/users_guide/glasgow_exts.rst
index e2dd28e9f7..bc9e0233f3 100644
--- a/docs/users_guide/glasgow_exts.rst
+++ b/docs/users_guide/glasgow_exts.rst
@@ -12004,6 +12004,48 @@ we show generic serialization:
 Typically this class will not be exported, as it only makes sense to
 have instances for the representation types.
 
+Unlifted representation types
+-----------------------------
+
+The data family ``URec`` is provided to enable generic programming over
+datatypes with certain unlifted arguments. There are six instances corresponding
+to common unlifted types: ::
+
+    data family URec a p
+
+    data instance URec (Ptr ()) p = UAddr   { uAddr#   :: Addr#   }
+    data instance URec Char     p = UChar   { uChar#   :: Char#   }
+    data instance URec Double   p = UDouble { uDouble# :: Double# }
+    data instance URec Int      p = UInt    { uInt#    :: Int#    }
+    data instance URec Float    p = UFloat  { uFloat#  :: Float#  }
+    data instance URec Word     p = UWord   { uWord#   :: Word#   }
+
+Six type synonyms are provided for convenience: ::
+
+    type UAddr   = URec (Ptr ())
+    type UChar   = URec Char
+    type UDouble = URec Double
+    type UFloat  = URec Float
+    type UInt    = URec Int
+    type UWord   = URec Word
+
+As an example, this data declaration: ::
+
+    data IntHash = IntHash Int#
+      deriving Generic
+
+results in the following ``Generic`` instance: ::
+
+    instance Generic IntHash where
+      type Rep IntHash =
+        D1 D1IntHash
+          (C1 C1_0IntHash
+            (S1 NoSelector UInt))
+
+A user could provide, for example, a ``GSerialize UInt`` instance so that a
+``Serialize IntHash`` instance could be easily defined in terms of
+``GSerialize``.
+
 Generic defaults
 ----------------
 
diff --git a/libraries/base/GHC/Generics.hs b/libraries/base/GHC/Generics.hs
index d98533b5b2..3e38930261 100644
--- a/libraries/base/GHC/Generics.hs
+++ b/libraries/base/GHC/Generics.hs
@@ -8,6 +8,7 @@
 {-# LANGUAGE StandaloneDeriving     #-}
 {-# LANGUAGE DeriveGeneric          #-}
 {-# LANGUAGE PolyKinds              #-}
+{-# LANGUAGE MagicHash              #-}
 
 -----------------------------------------------------------------------------
 -- |
@@ -532,6 +533,65 @@ module GHC.Generics  (
 -- @
 -- newtype (':.:') f g p = 'Comp1' { 'unComp1' :: f (g p) }
 -- @
+
+-- *** Representation of unlifted types
+--
+-- |
+--
+-- If one were to attempt to derive a Generic instance for a datatype with an
+-- unlifted argument (for example, 'Int#'), one might expect the occurrence of
+-- the 'Int#' argument to be marked with @'Rec0' 'Int#'@. This won't work,
+-- though, since 'Int#' is of kind @#@ and 'Rec0' expects a type of kind @*@.
+-- In fact, polymorphism over unlifted types is disallowed completely.
+--
+-- One solution would be to represent an occurrence of 'Int#' with 'Rec0 Int'
+-- instead. With this approach, however, the programmer has no way of knowing
+-- whether the 'Int' is actually an 'Int#' in disguise.
+--
+-- Instead of reusing 'Rec0', a separate data family 'URec' is used to mark
+-- occurrences of common unlifted types:
+--
+-- @
+-- data family URec a p
+--
+-- data instance 'URec' ('Ptr' ()) p = 'UAddr'   { 'uAddr#'   :: 'Addr#'   }
+-- data instance 'URec' 'Char'     p = 'UChar'   { 'uChar#'   :: 'Char#'   }
+-- data instance 'URec' 'Double'   p = 'UDouble' { 'uDouble#' :: 'Double#' }
+-- data instance 'URec' 'Int'      p = 'UFloat'  { 'uFloat#'  :: 'Float#'  }
+-- data instance 'URec' 'Float'    p = 'UInt'    { 'uInt#'    :: 'Int#'    }
+-- data instance 'URec' 'Word'     p = 'UWord'   { 'uWord#'   :: 'Word#'   }
+-- @
+--
+-- Several type synonyms are provided for convenience:
+--
+-- @
+-- type 'UAddr'   = 'URec' ('Ptr' ())
+-- type 'UChar'   = 'URec' 'Char'
+-- type 'UDouble' = 'URec' 'Double'
+-- type 'UFloat'  = 'URec' 'Float'
+-- type 'UInt'    = 'URec' 'Int'
+-- type 'UWord'   = 'URec' 'Word'
+-- @
+--
+-- The declaration
+--
+-- @
+-- data IntHash = IntHash Int#
+--   deriving 'Generic'
+-- @
+--
+-- yields
+--
+-- @
+-- instance 'Generic' IntHash where
+--   type 'Rep' IntHash =
+--     'D1' D1IntHash
+--       ('C1' C1_0IntHash
+--         ('S1' 'NoSelector' 'UInt'))
+-- @
+--
+-- Currently, only the six unlifted types listed above are generated, but this
+-- may be extended to encompass more unlifted types in the future.
 #if 0
 -- *** Limitations
 --
@@ -548,6 +608,11 @@ module GHC.Generics  (
     V1, U1(..), Par1(..), Rec1(..), K1(..), M1(..)
   , (:+:)(..), (:*:)(..), (:.:)(..)
 
+  -- ** Unboxed representation types
+  , URec(..)
+  , type UAddr, type UChar, type UDouble
+  , type UFloat, type UInt, type UWord
+
   -- ** Synonyms for convenience
   , Rec0, Par0, R, P
   , D1, C1, S1, D, C, S
@@ -562,6 +627,8 @@ module GHC.Generics  (
   ) where
 
 -- We use some base types
+import GHC.Prim ( Addr#, Char#, Double#, Float#, Int#, Word# )
+import GHC.Ptr ( Ptr )
 import GHC.Types
 import Data.Maybe ( Maybe(..) )
 import Data.Either ( Either(..) )
@@ -614,6 +681,46 @@ infixr 7 :.:
 newtype (:.:) f (g :: * -> *) (p :: *) = Comp1 { unComp1 :: f (g p) }
   deriving (Eq, Ord, Read, Show, Generic)
 
+-- | Constants of kind @#@
+data family URec (a :: *) (p :: *)
+
+-- | Used for marking occurrences of 'Addr#'
+data instance URec (Ptr ()) p = UAddr { uAddr# :: Addr# }
+  deriving (Eq, Ord, Generic)
+
+-- | Used for marking occurrences of 'Char#'
+data instance URec Char p = UChar { uChar# :: Char# }
+  deriving (Eq, Ord, Show, Generic)
+
+-- | Used for marking occurrences of 'Double#'
+data instance URec Double p = UDouble { uDouble# :: Double# }
+  deriving (Eq, Ord, Show, Generic)
+
+-- | Used for marking occurrences of 'Float#'
+data instance URec Float p = UFloat { uFloat# :: Float# }
+  deriving (Eq, Ord, Show, Generic)
+
+-- | Used for marking occurrences of 'Int#'
+data instance URec Int p = UInt { uInt# :: Int# }
+  deriving (Eq, Ord, Show, Generic)
+
+-- | Used for marking occurrences of 'Word#'
+data instance URec Word p = UWord { uWord# :: Word# }
+  deriving (Eq, Ord, Show, Generic)
+
+-- | Type synonym for 'URec': 'Addr#'
+type UAddr   = URec (Ptr ())
+-- | Type synonym for 'URec': 'Char#'
+type UChar   = URec Char
+-- | Type synonym for 'URec': 'Double#'
+type UDouble = URec Double
+-- | Type synonym for 'URec': 'Float#'
+type UFloat  = URec Float
+-- | Type synonym for 'URec': 'Int#'
+type UInt    = URec Int
+-- | Type synonym for 'URec': 'Word#'
+type UWord   = URec Word
+
 -- | Tag for K1: recursion (of kind *)
 data R
 -- | Tag for K1: parameters (other than the last)
@@ -642,7 +749,6 @@ type C1 = M1 C
 -- | Type synonym for encoding meta-information for record selectors
 type S1 = M1 S
 
-
 -- | Class for datatypes that represent datatypes
 class Datatype (d :: *) where
   -- | The name of the datatype (unqualified)
diff --git a/libraries/base/changelog.md b/libraries/base/changelog.md
index b40bfefe91..4874808d2d 100644
--- a/libraries/base/changelog.md
+++ b/libraries/base/changelog.md
@@ -62,6 +62,10 @@
     super-class of `Monoid` in the future). These modules were
     provided by the `semigroups` package previously. (#10365)
 
+  * Add `URec`, `UAddr`, `UChar`, `UDouble`, `UFloat`, `UInt`, and `UWord` to
+    `GHC.Generics` as part of making GHC generics capable of handling
+    unlifted types (#10868)
+
 ## 4.8.1.0  *Jul 2015*
 
   * Bundled with GHC 7.10.2
diff --git a/testsuite/tests/generics/GEq/GEq1.hs b/testsuite/tests/generics/GEq/GEq1.hs
index 164535cddb..d6ca0b057e 100644
--- a/testsuite/tests/generics/GEq/GEq1.hs
+++ b/testsuite/tests/generics/GEq/GEq1.hs
@@ -1,7 +1,9 @@
-{-# LANGUAGE TypeOperators, DeriveGeneric, TypeFamilies, FlexibleInstances #-}
+{-# LANGUAGE TypeOperators, DeriveGeneric, TypeFamilies,
+             FlexibleInstances, MagicHash #-}
 
 module Main where
 
+import GHC.Exts
 import GHC.Generics hiding (C, D)
 import GEq1A
 
@@ -20,6 +22,13 @@ data family F a b :: * -> *
 data instance F Int b c = F b Int c
   deriving Generic
 
+data U a = U a Addr# Char# Double# Float# Int# Word#
+  deriving Generic
+
+data family UF a b :: * -> *
+data instance UF Int b c = UF b c Addr# Char# Double# Float# Int# Word#
+  deriving Generic
+
 -- Example values
 c0 = C0
 c1 = C1
@@ -35,17 +44,27 @@ f1 :: F Int Float Char
 f1 = F 0.0 3 'h'
 f2 = F 0.0 4 'h'
 
+u0 :: U Int
+u0 = U 1 "1"# '1'# 1.0## 1.0# 1# 1##
+
+uf0 :: UF Int Int Int
+uf0 = UF 2 2 "1"# '2'# 2.0## 2.0# 2# 2##
+
 -- Generic instances
 instance                   GEq C
 instance (GEq a)        => GEq (D a)
 instance (GEq a, GEq b) => GEq (a :**: b)
 instance (GEq b, GEq c) => GEq (F Int b c)
+instance (GEq a)        => GEq (U a)
+instance (GEq b, GEq c) => GEq (UF Int b c)
 
 -- Tests
-teq0 = geq c0 c1
-teq1 = geq d0 d1
-teq2 = geq d0 d0
-teq3 = geq p1 p1
-teq4 = geq f1 f2
+teq0 = geq c0  c1
+teq1 = geq d0  d1
+teq2 = geq d0  d0
+teq3 = geq p1  p1
+teq4 = geq f1  f2
+teq5 = geq u0  u0
+teq6 = geq uf0 uf0
 
-main = mapM_ print [teq0, teq1, teq2, teq3, teq4]
+main = mapM_ print [teq0, teq1, teq2, teq3, teq4, teq5, teq6]
diff --git a/testsuite/tests/generics/GEq/GEq1.stdout b/testsuite/tests/generics/GEq/GEq1.stdout
index 3ce45b831d..e590e50cd2 100644
--- a/testsuite/tests/generics/GEq/GEq1.stdout
+++ b/testsuite/tests/generics/GEq/GEq1.stdout
@@ -3,3 +3,5 @@ False
 True
 True
 False
+True
+True
diff --git a/testsuite/tests/generics/GEq/GEq1A.hs b/testsuite/tests/generics/GEq/GEq1A.hs
index 7bdfbebe54..9a91e8040b 100644
--- a/testsuite/tests/generics/GEq/GEq1A.hs
+++ b/testsuite/tests/generics/GEq/GEq1A.hs
@@ -1,7 +1,9 @@
-{-# LANGUAGE TypeOperators, DefaultSignatures, FlexibleContexts, FlexibleInstances #-}
+{-# LANGUAGE TypeOperators, DefaultSignatures,
+             FlexibleContexts, FlexibleInstances, MagicHash #-}
 
 module GEq1A where
 
+import GHC.Exts
 import GHC.Generics
 
 class GEq' f where
@@ -26,13 +28,25 @@ instance (GEq' a, GEq' b) => GEq' (a :+: b) where
 instance (GEq' a, GEq' b) => GEq' (a :*: b) where
   geq' (a1 :*: b1) (a2 :*: b2) = geq' a1 a2 && geq' b1 b2
 
-
-class GEq a where 
+-- Unboxed types
+instance GEq' UAddr where
+  geq' (UAddr a1) (UAddr a2)     = isTrue# (eqAddr# a1 a2)
+instance GEq' UChar where
+  geq' (UChar c1) (UChar c2)     = isTrue# (eqChar# c1 c2)
+instance GEq' UDouble where
+  geq' (UDouble d1) (UDouble d2) = isTrue# (d1 ==## d2)
+instance GEq' UFloat where
+  geq' (UFloat f1) (UFloat f2)   = isTrue# (eqFloat# f1 f2)
+instance GEq' UInt where
+  geq' (UInt i1) (UInt i2)       = isTrue# (i1 ==# i2)
+instance GEq' UWord where
+  geq' (UWord w1) (UWord w2)     = isTrue# (eqWord# w1 w2)
+
+class GEq a where
   geq :: a -> a -> Bool
   default geq :: (Generic a, GEq' (Rep a)) => a -> a -> Bool
   geq x y = geq' (from x) (from y)
 
-
 -- Base types instances (ad-hoc)
 instance GEq Char   where geq = (==)
 instance GEq Int    where geq = (==)
diff --git a/testsuite/tests/generics/GShow/GShow.hs b/testsuite/tests/generics/GShow/GShow.hs
index 3c8f2591ef..6cdda282d8 100644
--- a/testsuite/tests/generics/GShow/GShow.hs
+++ b/testsuite/tests/generics/GShow/GShow.hs
@@ -5,13 +5,14 @@
 {-# LANGUAGE TypeOperators              #-}
 {-# LANGUAGE IncoherentInstances        #-} -- :-/
 {-# LANGUAGE DefaultSignatures          #-}
+{-# LANGUAGE MagicHash                  #-}
 
 module GShow (
   -- * Generic show class
     GShow(..)
   ) where
 
-
+import GHC.Exts
 import GHC.Generics
 
 --------------------------------------------------------------------------------
@@ -36,10 +37,10 @@ instance (GShow c) => GShow' (K1 i c) where
 -- No instances for P or Rec because gshow is only applicable to types of kind *
 
 instance (GShow' a, Constructor c) => GShow' (M1 C c a) where
-  gshowsPrec' _ n c@(M1 x) = 
+  gshowsPrec' _ n c@(M1 x) =
     case (fixity, conIsTuple c) of
-      (Prefix,False) -> showParen (n > 10 && not (isNullary x)) 
-                         ( showString (conName c) 
+      (Prefix,False) -> showParen (n > 10 && not (isNullary x))
+                         ( showString (conName c)
                          . if (isNullary x) then id else showChar ' '
                          . showBraces t (gshowsPrec' t 10 x))
       (Prefix,True)  -> showParen (n > 10) (showBraces t (gshowsPrec' t 10 x))
@@ -58,7 +59,7 @@ instance (GShow' a, Constructor c) => GShow' (M1 C c a) where
             conIsTuple c = case conName c of
                              ('(':',':_) -> True
                              otherwise   -> False
-  
+
   isNullary (M1 x) = isNullary x
 
 instance (Selector s, GShow' a) => GShow' (M1 S s a) where
@@ -85,12 +86,23 @@ instance (GShow' a, GShow' b) => GShow' (a :*: b) where
     gshowsPrec' t n     a . showChar ','    . gshowsPrec' t n     b
   gshowsPrec' t@Pref    n (a :*: b) =
     gshowsPrec' t (n+1) a . showChar ' '    . gshowsPrec' t (n+1) b
-  
+
   -- If we have a product then it is not a nullary constructor
   isNullary _ = False
 
-
-class GShow a where 
+-- Unboxed instances
+instance GShow' UChar where
+  gshowsPrec' _ _ (UChar c)   = showsPrec 0 (C# c) . showChar '#'
+instance GShow' UDouble where
+  gshowsPrec' _ _ (UDouble d) = showsPrec 0 (D# d) . showString "##"
+instance GShow' UFloat where
+  gshowsPrec' _ _ (UFloat f)  = showsPrec 0 (F# f) . showChar '#'
+instance GShow' UInt where
+  gshowsPrec' _ _ (UInt i)    = showsPrec 0 (I# i) . showChar '#'
+instance GShow' UWord where
+  gshowsPrec' _ _ (UWord w)   = showsPrec 0 (W# w) . showString "##"
+
+class GShow a where
   gshowsPrec :: Int -> a -> ShowS
   default gshowsPrec :: (Generic a, GShow' (Rep a)) => Int -> a -> ShowS
   gshowsPrec n = gshowsPrec' Pref n . from
@@ -100,13 +112,15 @@ class GShow a where
 
   gshow :: a -> String
   gshow x = gshows x ""
-  
+
 
 -- Base types instances
 instance GShow Char   where gshowsPrec = showsPrec
+instance GShow Double where gshowsPrec = showsPrec
 instance GShow Int    where gshowsPrec = showsPrec
 instance GShow Float  where gshowsPrec = showsPrec
 instance GShow String where gshowsPrec = showsPrec
+instance GShow Word   where gshowsPrec = showsPrec
 instance GShow Bool   where gshowsPrec = showsPrec
 
 intersperse :: a -> [a] -> [a]
diff --git a/testsuite/tests/generics/GShow/GShow1.stdout b/testsuite/tests/generics/GShow/GShow1.stdout
index 6109e446a5..71e1299245 100644
--- a/testsuite/tests/generics/GShow/GShow1.stdout
+++ b/testsuite/tests/generics/GShow/GShow1.stdout
@@ -1,3 +1,4 @@
 D0
 D1 {d11 = Just 'p', d12 = D0}
 D1 {d11 = (3,0.14), d12 = D0}
+U (1) ('1'#) (-1.0##) (-1.0#) (-1#) (1##)
diff --git a/testsuite/tests/generics/GShow/Main.hs b/testsuite/tests/generics/GShow/Main.hs
index 81768ed647..952602e54d 100644
--- a/testsuite/tests/generics/GShow/Main.hs
+++ b/testsuite/tests/generics/GShow/Main.hs
@@ -1,12 +1,14 @@
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveGeneric, MagicHash #-}
 
 module Main where
 
+import GHC.Exts
 import GHC.Generics hiding (C, D)
 import GShow
 
 -- We should be able to generate a generic representation for these types
 data D a = D0 | D1 { d11 :: a, d12 :: (D a) } deriving Generic
+data U a = U a Char# Double# Float# Int# Word# deriving Generic
 
 -- Example values
 d0 :: D Char
@@ -16,8 +18,12 @@ d1 = D1 (Just 'p') D0
 d2 :: D (Int,Float)
 d2 = D1 (3,0.14) D0
 
+u0 :: U Int
+u0 = U 1 '1'# -1.0## -1.0# -1# 1##
+
 -- Generic instances
 instance (GShow a) => GShow (D a)
+instance (GShow a) => GShow (U a)
 
 -- Tests
-main = mapM_ putStrLn [gshow d0, gshow d1, gshow d2]
+main = mapM_ putStrLn [gshow d0, gshow d1, gshow d2, gshow u0]
diff --git a/testsuite/tests/generics/T8468.stderr b/testsuite/tests/generics/T8468.stderr
index 62536cec69..aaf68b9d5a 100644
--- a/testsuite/tests/generics/T8468.stderr
+++ b/testsuite/tests/generics/T8468.stderr
@@ -1,5 +1,5 @@
 
 T8468.hs:6:42:
     Can't make a derived instance of ‘Generic1 Array’:
-      Array must not have unlifted or polymorphic arguments
+      Array must not have exotic unlifted or polymorphic arguments
     In the data declaration for ‘Array’