Merge branch 'master' of darcs.haskell.org:/home/darcs/ghc

25 files changed, 326 insertions, 140 deletions

diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs
index c88fa8097d..a0cc4bdbdf 100644
--- a/compiler/basicTypes/DataCon.lhs
+++ b/compiler/basicTypes/DataCon.lhs
@@ -19,6 +19,7 @@ module DataCon (
 	
 	-- ** Type construction
 	mkDataCon, fIRST_TAG,
+        buildAlgTyCon, 
 	
 	-- ** Type deconstruction
 	dataConRepType, dataConSig, dataConFullSig,
@@ -45,8 +46,7 @@ module DataCon (
 	splitProductType_maybe, splitProductType, 
 
         -- ** Promotion related functions
-        isPromotableTyCon, promoteTyCon, 
-        promoteDataCon, promoteDataCon_maybe
+        promoteKind, promoteDataCon, promoteDataCon_maybe
     ) where
 
 #include "HsVersions.h"
@@ -55,6 +55,7 @@ import {-# SOURCE #-} MkId( DataConBoxer )
 import Type
 import TypeRep( Type(..) )  -- Used in promoteType
 import PrelNames( liftedTypeKindTyConKey )
+import ForeignCall( CType )
 import Coercion
 import Kind
 import Unify
@@ -73,6 +74,7 @@ import VarEnv
 
 import qualified Data.Data as Data
 import qualified Data.Typeable
+import Data.Maybe
 import Data.Char
 import Data.Word
 \end{code}
@@ -640,7 +642,6 @@ mkDataCon name declared_infix
                   dcRepArity = length rep_arg_tys,
                   dcPromoted = mb_promoted }
 
-	-- 
 	-- The 'arg_stricts' passed to mkDataCon are simply those for the
 	-- source-language arguments.  We add extra ones for the
 	-- dictionary arguments right here.
@@ -652,11 +653,9 @@ mkDataCon name declared_infix
 	     mkTyConApp rep_tycon (mkTyVarTys univ_tvs)
 
     mb_promoted   -- See Note [Promoted data constructors] in TyCon
-      | all (isLiftedTypeKind . tyVarKind) (univ_tvs ++ ex_tvs)
-                          -- No kind polymorphism, and all of kind *
-      , null eq_spec   -- No constraints
-      , null theta
-      , all isPromotableType orig_arg_tys
+      | 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)
       | otherwise 
       = Nothing          
@@ -996,6 +995,41 @@ dataConCannotMatch tys con
 
 %************************************************************************
 %*									*
+              Building an algebraic data type
+%*									*
+%************************************************************************
+
+\begin{code}
+buildAlgTyCon :: Name 
+              -> [TyVar]               -- ^ Kind variables and type variables
+	      -> Maybe CType
+	      -> ThetaType	       -- ^ Stupid theta
+	      -> AlgTyConRhs
+	      -> RecFlag
+	      -> Bool		       -- ^ True <=> this TyCon is promotable
+	      -> Bool		       -- ^ True <=> was declared in GADT syntax
+              -> TyConParent
+	      -> TyCon
+
+buildAlgTyCon tc_name ktvs 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 
+                    rhs parent is_rec gadt_syn 
+                    mb_promoted_tc
+
+    mb_promoted_tc
+      | is_promotable = Just (mkPromotedTyCon tc (promoteKind kind))
+      | otherwise     = Nothing
+\end{code}
+
+
+%************************************************************************
+%*									*
 \subsection{Splitting products}
 %*									*
 %************************************************************************
@@ -1052,7 +1086,6 @@ splitProductType str ty
 
 These two 'promoted..' functions are here because
  * They belong together
- * 'promoteTyCon'  is used by promoteType
  * 'prmoteDataCon' depends on DataCon stuff
 
 \begin{code}
@@ -1062,10 +1095,6 @@ promoteDataCon dc = pprPanic "promoteDataCon" (ppr dc)
 
 promoteDataCon_maybe :: DataCon -> Maybe TyCon
 promoteDataCon_maybe (MkData { dcPromoted = mb_tc }) = mb_tc
-
-promoteTyCon :: TyCon -> TyCon
-promoteTyCon tc
-  = mkPromotedTyCon tc (promoteKind (tyConKind tc))
 \end{code}
 
 Note [Promoting a Type to a Kind]
@@ -1086,24 +1115,6 @@ The transformation from type to kind is done by promoteType
           * -> ... -> * -> *
 
 \begin{code}
-isPromotableType :: Type -> Bool
-isPromotableType (TyConApp tc tys) 
-  | Just n <- isPromotableTyCon tc = tys `lengthIs` n && all isPromotableType tys
-isPromotableType (FunTy arg res)   = isPromotableType arg && isPromotableType res
-isPromotableType (TyVarTy {})      = True
-isPromotableType _                 = False
-
--- If tc's kind is [ *^n -> * ] returns [ Just n ], else returns [ Nothing ]
-isPromotableTyCon :: TyCon -> Maybe Int
-isPromotableTyCon tc
-  | isDataTyCon tc || isNewTyCon tc
-       -- Only *data* and *newtype* types can be promoted, 
-       -- not synonyms, not type/data families
-  , all isLiftedTypeKind (res:args) = Just $ length args
-  | otherwise                       = Nothing
-  where
-    (args, res) = splitKindFunTys (tyConKind tc)
-
 -- | Promotes a type to a kind. 
 -- Assumes the argument satisfies 'isPromotableType'
 promoteType :: Type -> Kind
@@ -1114,7 +1125,8 @@ promoteType ty
     kvs = [ mkKindVar (tyVarName tv) superKind | tv <- tvs ]
     env = zipVarEnv tvs kvs
 
-    go (TyConApp tc tys) = mkTyConApp (promoteTyCon tc) (map go tys)
+    go (TyConApp tc tys) | Just prom_tc <- promotableTyCon_maybe tc
+                         = mkTyConApp prom_tc (map go tys)
     go (FunTy arg res)   = mkArrowKind (go arg) (go res)
     go (TyVarTy tv)      | Just kv <- lookupVarEnv env tv 
                          = TyVarTy kv
diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index 7017f709cb..9b527e7fcf 100644
--- a/compiler/coreSyn/CoreUtils.lhs
+++ b/compiler/coreSyn/CoreUtils.lhs
@@ -1712,8 +1712,14 @@ tryEtaReduce bndrs body
 
     ---------------
     fun_arity fun             -- See Note [Arity care]
-       | isLocalId fun && isStrongLoopBreaker (idOccInfo fun) = 0
-       | otherwise = idArity fun
+       | isLocalId fun
+       , isStrongLoopBreaker (idOccInfo fun) = 0
+       | arity > 0                           = arity
+       | isEvaldUnfolding (idUnfolding fun)  = 1  
+            -- See Note [Eta reduction of an eval'd function]
+       | otherwise                           = 0
+       where
+         arity = idArity fun
 
     ---------------
     ok_lam v = isTyVar v || isEvVar v
@@ -1737,6 +1743,20 @@ tryEtaReduce bndrs body
     ok_arg _ _ _ = Nothing
 \end{code}
 
+Note [Eta reduction of an eval'd function]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In Haskell is is not true that    f = \x. f x
+because f might be bottom, and 'seq' can distinguish them.
+
+But it *is* true that   f = f `seq` \x. f x 
+and we'd like to simplify the latter to the former.  This amounts
+to the rule that 
+  * when there is just *one* value argument,
+  * f is not bottom
+we can eta-reduce    \x. f x  ===>  f
+
+This turned up in Trac #7542.  
+
 
 %************************************************************************
 %*                                                                      *
diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs
index 39801bf64c..ac244fab79 100644
--- a/compiler/iface/BinIface.hs
+++ b/compiler/iface/BinIface.hs
@@ -1236,7 +1236,7 @@ instance Binary IfaceDecl where
     put_ _ (IfaceForeign _ _) = 
         error "Binary.put_(IfaceDecl): IfaceForeign"
 
-    put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) = do
+    put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8 a9) = do
         putByte bh 2
         put_ bh (occNameFS a1)
         put_ bh a2
@@ -1246,6 +1246,7 @@ instance Binary IfaceDecl where
         put_ bh a6
         put_ bh a7
         put_ bh a8
+        put_ bh a9
 
     put_ bh (IfaceSyn a1 a2 a3 a4) = do
         putByte bh 3
@@ -1288,8 +1289,9 @@ instance Binary IfaceDecl where
                     a6 <- get bh
                     a7 <- get bh
                     a8 <- get bh
+                    a9 <- get bh
                     occ <- return $! mkOccNameFS tcName a1
-                    return (IfaceData occ a2 a3 a4 a5 a6 a7 a8)
+                    return (IfaceData occ a2 a3 a4 a5 a6 a7 a8 a9)
             3 -> do a1 <- get bh
                     a2 <- get bh
                     a3 <- get bh
diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs
index 495c6b9deb..d5e4a4a62e 100644
--- a/compiler/iface/BuildTyCl.lhs
+++ b/compiler/iface/BuildTyCl.lhs
@@ -29,7 +29,6 @@ import DataCon
 import Var
 import VarSet
 import BasicTypes
-import ForeignCall
 import Name
 import MkId
 import Class
@@ -56,21 +55,6 @@ buildSynTyCon tc_name tvs rhs rhs_kind parent
   = return (mkSynTyCon tc_name kind tvs rhs parent)
   where kind = mkPiKinds tvs rhs_kind
 
-------------------------------------------------------
-buildAlgTyCon :: Name 
-              -> [TyVar]               -- ^ Kind variables and type variables
-	      -> Maybe CType
-	      -> ThetaType	       -- ^ Stupid theta
-	      -> AlgTyConRhs
-	      -> RecFlag
-	      -> Bool		       -- ^ True <=> was declared in GADT syntax
-              -> TyConParent
-	      -> TyCon
-
-buildAlgTyCon tc_name ktvs cType stupid_theta rhs is_rec gadt_syn parent
-  = mkAlgTyCon tc_name kind ktvs cType stupid_theta rhs parent is_rec gadt_syn
-  where 
-    kind = mkPiKinds ktvs liftedTypeKind
 
 ------------------------------------------------------
 distinctAbstractTyConRhs, totallyAbstractTyConRhs :: AlgTyConRhs
diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index 9ef5ef66f4..8ba5e86eb9 100644
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -82,6 +82,7 @@ data IfaceDecl
                 ifCtxt       :: IfaceContext,   -- The "stupid theta"
                 ifCons       :: IfaceConDecls,  -- Includes new/data/data family info
                 ifRec        :: RecFlag,        -- Recursive or not?
+                ifPromotable :: Bool,           -- Promotable to kind level?
                 ifGadtSyntax :: Bool,           -- True <=> declared using
                                                 -- GADT syntax
                 ifAxiom      :: Maybe IfExtName -- The axiom, for a newtype, 
@@ -511,11 +512,16 @@ pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
 pprIfaceDecl (IfaceData {ifName = tycon, ifCType = cType,
                          ifCtxt = context,
                          ifTyVars = tyvars, ifCons = condecls,
-                         ifRec = isrec, ifAxiom = mbAxiom})
+                         ifRec = isrec, ifPromotable = is_prom,
+                         ifAxiom = mbAxiom})
   = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars)
-       4 (vcat [pprCType cType, pprRec isrec, pp_condecls tycon condecls,
-                pprAxiom mbAxiom])
+       4 (vcat [ pprCType cType
+               , pprRec isrec <> comma <+> pp_prom 
+               , pp_condecls tycon condecls
+               , pprAxiom mbAxiom])
   where
+    pp_prom | is_prom   = ptext (sLit "Promotable")
+            | otherwise = ptext (sLit "Not promotable")
     pp_nd = case condecls of
                 IfAbstractTyCon dis -> ptext (sLit "abstract") <> parens (ppr dis)
                 IfDataFamTyCon     -> ptext (sLit "data family")
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index 2200577c59..f145ec1a3a 100644
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -1479,6 +1479,7 @@ tyConToIfaceDecl env tycon
                 ifCons    = ifaceConDecls (algTyConRhs tycon),
                 ifRec     = boolToRecFlag (isRecursiveTyCon tycon),
                 ifGadtSyntax = isGadtSyntaxTyCon tycon,
+                ifPromotable = isJust (promotableTyCon_maybe tycon),
                 ifAxiom   = fmap coAxiomName (tyConFamilyCoercion_maybe tycon) }
 
   | isForeignTyCon tycon
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index 930bb1e2a2..3ef0ddcf18 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -437,7 +437,7 @@ tc_iface_decl parent _ (IfaceData {ifName = occ_name,
                           ifTyVars = tv_bndrs, 
                           ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
                           ifCons = rdr_cons, 
-                          ifRec = is_rec, 
+                          ifRec = is_rec, ifPromotable = is_prom, 
                           ifAxiom = mb_axiom_name })
   = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do
     { tc_name <- lookupIfaceTop occ_name
@@ -446,7 +446,7 @@ tc_iface_decl parent _ (IfaceData {ifName = occ_name,
             ; parent' <- tc_parent tyvars mb_axiom_name
             ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons
             ; return (buildAlgTyCon tc_name tyvars cType stupid_theta 
-                                    cons is_rec gadt_syn parent') }
+                                    cons is_rec is_prom gadt_syn parent') }
     ; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
     ; return (ATyCon tycon) }
   where
@@ -1393,8 +1393,10 @@ tcIfaceKindCon (IfaceTc name)
        ; case thing of    -- A "type constructor" here is a promoted type constructor
                           --           c.f. Trac #5881
            ATyCon tc 
-             | isSuperKind (tyConKind tc) -> return tc   -- Mainly just '*' or 'AnyK'
-             | otherwise                  -> return (promoteTyCon tc)
+             | isSuperKind (tyConKind tc) 
+             -> return tc   -- Mainly just '*' or 'AnyK'
+             | Just prom_tc <- promotableTyCon_maybe tc
+             -> return prom_tc
 
            _ -> pprPanic "tcIfaceKindCon" (ppr name $$ ppr thing) }
 
diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs
index 218870a5b8..5d9fb23fe9 100644
--- a/compiler/llvmGen/LlvmCodeGen/Ppr.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs
@@ -58,6 +58,9 @@ moduleLayout = sdocWithPlatform $ \platform ->
     Platform { platformArch = ArchARM {}, platformOS = OSLinux } ->
         text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:64:128-a0:0:64-n32\""
         $+$ text "target triple = \"arm-unknown-linux-gnueabi\""
+    Platform { platformArch = ArchARM {}, platformOS = OSAndroid } ->
+        text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:64:128-a0:0:64-n32\""
+        $+$ text "target triple = \"arm-unknown-linux-androideabi\""
     _ ->
         -- FIX: Other targets
         empty
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index f47aea7097..c24bb51833 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -1752,7 +1752,16 @@ linkBinary dflags o_files dep_packages = do
                   rpath = if gopt Opt_RPath dflags
                           then ["-Wl,-rpath",      "-Wl," ++ libpath]
                           else []
-              in ["-L" ++ l, "-Wl,-rpath-link", "-Wl," ++ l] ++ rpath
+                  -- Solaris 11's linker does not support -rpath-link option. It silently
+                  -- ignores it and then complains about next option which is -l<some
+                  -- dir> as being a directory and not expected object file, E.g
+                  -- ld: elf error: file
+                  -- /tmp/ghc-src/libraries/base/dist-install/build:
+                  -- elf_begin: I/O error: region read: Is a directory
+                  rpathlink = if (platformOS platform) == OSSolaris2
+                              then []
+                              else ["-Wl,-rpath-link", "-Wl," ++ l]
+              in ["-L" ++ l] ++ rpathlink ++ rpath
          | otherwise = ["-L" ++ l]
 
     let lib_paths = libraryPaths dflags
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index e2f10c76ce..feadd3d6a8 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -3376,7 +3376,7 @@ makeDynFlagsConsistent dflags
       else let dflags' = dflags { hscTarget = HscLlvm }
                warn = "Compiler not unregisterised, so using LLVM rather than compiling via C"
            in loop dflags' warn
- | hscTarget dflags /= HscC &&
+ | hscTarget dflags /= HscC && hscTarget dflags /= HscLlvm &&
    platformUnregisterised (targetPlatform dflags)
     = loop (dflags { hscTarget = HscC })
            "Compiler unregisterised, so compiling via C"
diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index 1d3a7f9d9b..261d10295f 100644
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@ -1411,11 +1411,11 @@ repTyConKey  = mkPreludeTyConUnique 155
 rep1TyConKey = mkPreludeTyConUnique 156
 
 -- Type-level naturals
-typeNatKindConNameKey, typeStringKindConNameKey,
+typeNatKindConNameKey, typeSymbolKindConNameKey,
   typeNatAddTyFamNameKey, typeNatMulTyFamNameKey, typeNatExpTyFamNameKey
   :: Unique
 typeNatKindConNameKey     = mkPreludeTyConUnique 160
-typeStringKindConNameKey  = mkPreludeTyConUnique 161
+typeSymbolKindConNameKey  = mkPreludeTyConUnique 161
 typeNatAddTyFamNameKey    = mkPreludeTyConUnique 162
 typeNatMulTyFamNameKey    = mkPreludeTyConUnique 163
 typeNatExpTyFamNameKey    = mkPreludeTyConUnique 164
diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs
index d94de113e4..e83fcb5255 100644
--- a/compiler/prelude/TysWiredIn.lhs
+++ b/compiler/prelude/TysWiredIn.lhs
@@ -65,7 +65,7 @@ module TysWiredIn (
 	unitTy,
 
         -- * Kinds
-	typeNatKindCon, typeNatKind, typeStringKindCon, typeStringKind,
+	typeNatKindCon, typeNatKind, typeSymbolKindCon, typeSymbolKind,
 
         -- * Parallel arrays
 	mkPArrTy,
@@ -152,7 +152,7 @@ wiredInTyCons = [ unitTyCon	-- Not treated like other tuples, because
 	      , parrTyCon
               , eqTyCon
               , typeNatKindCon
-              , typeStringKindCon
+              , typeSymbolKindCon
     	      ]
            ++ (case cIntegerLibraryType of
                IntegerGMP -> [integerTyCon]
@@ -199,9 +199,9 @@ doubleTyConName    = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Double")
 doubleDataConName  = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "D#") doubleDataConKey doubleDataCon
 
 -- Kinds
-typeNatKindConName, typeStringKindConName :: Name
+typeNatKindConName, typeSymbolKindConName :: Name
 typeNatKindConName    = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "Nat")    typeNatKindConNameKey    typeNatKindCon
-typeStringKindConName = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "Symbol") typeStringKindConNameKey typeStringKindCon 
+typeSymbolKindConName = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "Symbol") typeSymbolKindConNameKey typeSymbolKindCon 
 
 -- For integer-gmp only:
 integerRealTyConName :: Name
@@ -240,23 +240,22 @@ eqTyCon_RDR     = nameRdrName eqTyConName
 
 \begin{code}
 pcNonRecDataTyCon :: Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon
-pcNonRecDataTyCon = pcTyCon False NonRecursive
-pcRecDataTyCon :: Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon
-pcRecDataTyCon    = pcTyCon False Recursive
+-- Not an enumeration, not promotable
+pcNonRecDataTyCon = pcTyCon False NonRecursive False
 
-pcTyCon :: Bool -> RecFlag -> Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon
-pcTyCon is_enum is_rec name cType tyvars cons
+pcTyCon :: Bool -> RecFlag -> Bool -> Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon
+pcTyCon is_enum is_rec is_prom name cType tyvars cons
   = tycon
   where
-    tycon = mkAlgTyCon name
-		(mkArrowKinds (map tyVarKind tyvars) liftedTypeKind)
+    tycon = buildAlgTyCon name
                 tyvars
                 cType
                 []		-- No stupid theta
 		(DataTyCon cons is_enum)
-		NoParentTyCon
                 is_rec
+                is_prom
 		False		-- Not in GADT syntax
+		NoParentTyCon
 
 pcDataCon :: Name -> [TyVar] -> [Type] -> TyCon -> DataCon
 pcDataCon = pcDataConWithFixity False
@@ -305,15 +304,15 @@ pcDataConWithFixity' declared_infix dc_name wrk_key tyvars arg_tys tycon
 %************************************************************************
 
 \begin{code}
-typeNatKindCon, typeStringKindCon :: TyCon 
+typeNatKindCon, typeSymbolKindCon :: TyCon 
 -- data Nat
 -- data Symbol
-typeNatKindCon    = pcNonRecDataTyCon typeNatKindConName    Nothing [] []
-typeStringKindCon = pcNonRecDataTyCon typeStringKindConName Nothing [] []
+typeNatKindCon    = pcTyCon False NonRecursive True typeNatKindConName    Nothing [] []
+typeSymbolKindCon = pcTyCon False NonRecursive True typeSymbolKindConName Nothing [] []
 
-typeNatKind, typeStringKind :: Kind
+typeNatKind, typeSymbolKind :: Kind
 typeNatKind    = TyConApp (promoteTyCon typeNatKindCon)    []
-typeStringKind = TyConApp (promoteTyCon typeStringKindCon) []
+typeSymbolKind = TyConApp (promoteTyCon typeSymbolKindCon) []
 \end{code}
 
 
@@ -368,7 +367,12 @@ factTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple ConstraintTuple i | i <- [
 mk_tuple :: TupleSort -> Int -> (TyCon,DataCon)
 mk_tuple sort arity = (tycon, tuple_con)
   where
-	tycon   = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con sort 
+	tycon   = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con sort prom_tc
+        prom_tc = case sort of
+	  BoxedTuple   	  -> Just (mkPromotedTyCon tycon (promoteKind tc_kind))
+	  UnboxedTuple 	  -> Nothing
+	  ConstraintTuple -> Nothing
+
 	modu	= mkTupleModule sort arity
 	tc_name = mkWiredInName modu (mkTupleOcc tcName sort arity) tc_uniq
 				(ATyCon tycon) BuiltInSyntax
@@ -434,6 +438,7 @@ eqTyCon = mkAlgTyCon eqTyConName
             NoParentTyCon
             NonRecursive
             False
+            Nothing   -- No parent for constraint-kinded types
   where
     kv = kKiVar
     k = mkTyVarTy kv
@@ -579,7 +584,7 @@ boolTy :: Type
 boolTy = mkTyConTy boolTyCon
 
 boolTyCon :: TyCon
-boolTyCon = pcTyCon True NonRecursive boolTyConName
+boolTyCon = pcTyCon True NonRecursive True boolTyConName
                     (Just (CType Nothing (fsLit "HsBool")))
                     [] [falseDataCon, trueDataCon]
 
@@ -592,7 +597,7 @@ falseDataConId = dataConWorkId falseDataCon
 trueDataConId  = dataConWorkId trueDataCon
 
 orderingTyCon :: TyCon
-orderingTyCon = pcTyCon True NonRecursive orderingTyConName Nothing
+orderingTyCon = pcTyCon True NonRecursive True orderingTyConName Nothing
                         [] [ltDataCon, eqDataCon, gtDataCon]
 
 ltDataCon, eqDataCon, gtDataCon :: DataCon
@@ -626,7 +631,8 @@ mkListTy :: Type -> Type
 mkListTy ty = mkTyConApp listTyCon [ty]
 
 listTyCon :: TyCon
-listTyCon = pcRecDataTyCon listTyConName Nothing alpha_tyvar [nilDataCon, consDataCon]
+listTyCon = pcTyCon False Recursive True
+                    listTyConName Nothing alpha_tyvar [nilDataCon, consDataCon]
 
 mkPromotedListTy :: Type -> Type
 mkPromotedListTy ty = mkTyConApp promotedListTyCon [ty]
diff --git a/compiler/prelude/TysWiredIn.lhs-boot b/compiler/prelude/TysWiredIn.lhs-boot
index 65c03c8e17..b6dab8a21b 100644
--- a/compiler/prelude/TysWiredIn.lhs-boot
+++ b/compiler/prelude/TysWiredIn.lhs-boot
@@ -6,6 +6,6 @@ import {-# SOURCE #-} TypeRep    (Type)
 
 
 eqTyCon :: TyCon
-typeNatKind, typeStringKind :: Type
+typeNatKind, typeSymbolKind :: Type
 mkBoxedTupleTy :: [Type] -> Type
 \end{code}
diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs
index 02e9a1b020..00c55e533f 100644
--- a/compiler/simplCore/SimplUtils.lhs
+++ b/compiler/simplCore/SimplUtils.lhs
@@ -1141,7 +1141,7 @@ tryEtaExpand env bndr rhs
       | sm_eta_expand (getMode env)      -- Provided eta-expansion is on
       , let new_arity = findArity dflags bndr rhs old_arity
       , new_arity > manifest_arity      -- And the curent manifest arity isn't enough
-                                        -- See Note [Eta expansion to manifes arity]
+                                        -- See Note [Eta expansion to manifest arity]
       = do { tick (EtaExpansion bndr)
            ; return (new_arity, etaExpand new_arity rhs) }
       | otherwise
diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index f2ab037207..2d00d296ff 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -1676,15 +1676,23 @@ not want to transform to
    in blah
 because that builds an unnecessary thunk.
 
-We used also to do case elimination if
-        (c) the scrutinee is a variable and 'x' is used strictly
-But that changes
+Note [Case binder next]
+~~~~~~~~~~~~~~~~~~~~~~~
+If we have 
+   case e of f { _ -> f e1 e2 }
+then we can safely do CaseElim.   The main criterion is that the
+case-binder is evaluated *next*.  Previously we just asked that
+the case-binder is used strictly; but that can change
     case x of { _ -> error "bad" }
     --> error "bad"
 which is very puzzling if 'x' is later bound to (error "good").
 Where the order of evaluation is specified (via seq or case)
-we should respect it.  See also
-Note [Empty case alternatives] in CoreSyn.
+we should respect it.  
+See also Note [Empty case alternatives] in CoreSyn.
+
+So instead we use case_bndr_evald_next to see when f is the *next*
+thing to be eval'd.  This came up when fixing Trac #7542.
+See also Note [Eta reduction of an eval'd function] in CoreUtils.
 
   For reference, the old code was an extra disjunct in elim_lifted
        || (strict_case_bndr && scrut_is_var scrut)
@@ -1693,6 +1701,8 @@ Note [Empty case alternatives] in CoreSyn.
       scrut_is_var (Var _)    = True
       scrut_is_var _          = False
 
+      -- True if evaluation of the case_bndr is the next
+      -- thing to be eval'd.  Then dropping the case
 
 Note [Case elimination: unlifted case]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1817,12 +1827,13 @@ rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont
       = exprIsHNF scrut
      || (is_plain_seq && ok_for_spec)
               -- Note: not the same as exprIsHNF
+     || case_bndr_evald_next rhs
 
     elim_unlifted
       | is_plain_seq = exprOkForSideEffects scrut
             -- The entire case is dead, so we can drop it,
             -- _unless_ the scrutinee has side effects
-      | otherwise    = exprOkForSpeculation scrut
+      | otherwise    = ok_for_spec
             -- The case-binder is alive, but we may be able
             -- turn the case into a let, if the expression is ok-for-spec
             -- See Note [Case elimination: unlifted case]
@@ -1830,6 +1841,15 @@ rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont
     ok_for_spec      = exprOkForSpeculation scrut
     is_plain_seq     = isDeadBinder case_bndr -- Evaluation *only* for effect
 
+    case_bndr_evald_next :: CoreExpr -> Bool
+      -- See Note [Case binder next]
+    case_bndr_evald_next (Var v)         = v == case_bndr
+    case_bndr_evald_next (Cast e _)      = case_bndr_evald_next e
+    case_bndr_evald_next (App e _)       = case_bndr_evald_next e
+    case_bndr_evald_next (Case e _ _ _)  = case_bndr_evald_next e
+    case_bndr_evald_next _               = False
+      -- Could add a case for Let,
+      -- but I'm worried it could become expensive
 
 --------------------------------------------------
 --      3. Try seq rules; see Note [User-defined RULES for seq] in MkId
diff --git a/compiler/typecheck/TcGenGenerics.lhs b/compiler/typecheck/TcGenGenerics.lhs
index 819d7c1e09..3095dac07c 100644
--- a/compiler/typecheck/TcGenGenerics.lhs
+++ b/compiler/typecheck/TcGenGenerics.lhs
@@ -106,7 +106,10 @@ genGenericMetaTyCons tc mod =
         
         mkTyCon name = ASSERT( isExternalName name )
                        buildAlgTyCon name [] Nothing [] distinctAbstractTyConRhs
-                                          NonRecursive False NoParentTyCon
+                                          NonRecursive 
+                                          False          -- Not promotable
+                                          False          -- Not GADT syntax
+                                          NoParentTyCon
 
       let metaDTyCon  = mkTyCon d_name
           metaCTyCons = map mkTyCon c_names
diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs
index 2f95dfc641..cd5e029c61 100644
--- a/compiler/typecheck/TcHsType.lhs
+++ b/compiler/typecheck/TcHsType.lhs
@@ -511,8 +511,8 @@ tc_hs_type hs_ty@(HsTyLit (HsNumTy n)) exp_kind
        ; return (mkNumLitTy n) }
 
 tc_hs_type hs_ty@(HsTyLit (HsStrTy s)) exp_kind 
-  = do { checkExpectedKind hs_ty typeStringKind exp_kind
-       ; checkWiredInTyCon typeStringKindCon
+  = do { checkExpectedKind hs_ty typeSymbolKind exp_kind
+       ; checkWiredInTyCon typeSymbolKindCon
        ; return (mkStrLitTy s) }
 
 ---------------------------
@@ -626,8 +626,9 @@ tcTyVar name         -- Could be a tyvar, a tycon, or a datacon
              -> do { data_kinds <- xoptM Opt_DataKinds
                    ; unless data_kinds $ promotionErr name NoDataKinds
                    ; inst_tycon (mkTyConApp tc) (tyConKind tc) }
-             | otherwise -> failWithTc (quotes (ppr dc) <+> ptext (sLit "of type")
-                            <+> quotes (ppr (dataConUserType dc)) <+> ptext (sLit "is not promotable"))
+             | otherwise -> failWithTc (ptext (sLit "Data constructor") <+> quotes (ppr dc)
+                                        <+> ptext (sLit "comes from an un-promotable type") 
+                                        <+> quotes (ppr (dataConTyCon dc)))
 
            APromotionErr err -> promotionErr name err
 
@@ -1485,9 +1486,9 @@ tc_kind_var_app name arg_kis
   	   AGlobal (ATyCon tc)
   	     -> do { data_kinds <- xoptM Opt_DataKinds
   	           ; unless data_kinds $ addErr (dataKindsErr name)
-  	     	   ; case isPromotableTyCon tc of
-  	     	       Just n | n == length arg_kis ->
-  	     	         return (mkTyConApp (promoteTyCon tc) arg_kis)
+  	     	   ; case promotableTyCon_maybe tc of
+  	     	       Just prom_tc | arg_kis `lengthIs` tyConArity prom_tc
+  	     	               -> return (mkTyConApp prom_tc arg_kis)
   	     	       Just _  -> tycon_err tc "is not fully applied"
   	     	       Nothing -> tycon_err tc "is not promotable" }
 
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index 7b3722e2b4..26b6c755d0 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -715,7 +715,9 @@ tcDataFamInstDecl mb_clsinfo fam_tc
                     fam_inst = mkDataFamInst axiom_name tvs'' fam_tc pats'' rep_tc
                     parent   = FamInstTyCon (famInstAxiom fam_inst) fam_tc pats''
                     rep_tc   = buildAlgTyCon rep_tc_name tvs'' cType stupid_theta tc_rhs 
-                                             Recursive h98_syntax parent
+                                             Recursive 
+                                             False      -- No promotable to the kind level
+                                             h98_syntax parent
                  -- We always assume that indexed types are recursive.  Why?
                  -- (1) Due to their open nature, we can never be sure that a
                  -- further instance might not introduce a new recursive
diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 3a8a1c08f0..8f880e12e9 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -565,32 +565,32 @@ TyCons or Classes of this recursive group.  Earlier, finished groups,
 live in the global env only.
 
 \begin{code}
-tcTyClDecl :: (Name -> RecFlag) -> LTyClDecl Name -> TcM [TyThing]
-tcTyClDecl calc_isrec (L loc decl)
+tcTyClDecl :: RecTyInfo -> LTyClDecl Name -> TcM [TyThing]
+tcTyClDecl rec_info (L loc decl)
   = setSrcSpan loc $ tcAddDeclCtxt decl $
     traceTc "tcTyAndCl-x" (ppr decl) >>
-    tcTyClDecl1 NoParentTyCon calc_isrec decl
+    tcTyClDecl1 NoParentTyCon rec_info decl
 
   -- "type family" declarations
-tcTyClDecl1 :: TyConParent -> (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing]
-tcTyClDecl1 parent _calc_isrec (FamDecl { tcdFam = fd })
+tcTyClDecl1 :: TyConParent -> RecTyInfo -> TyClDecl Name -> TcM [TyThing]
+tcTyClDecl1 parent _rec_info (FamDecl { tcdFam = fd })
   = tcFamDecl1 parent fd
 
   -- "type" synonym declaration
-tcTyClDecl1 _parent _calc_isrec
+tcTyClDecl1 _parent _rec_info
             (SynDecl { tcdLName = L _ tc_name, tcdTyVars = tvs, tcdRhs = rhs })
   = ASSERT( isNoParent _parent )
     tcTyClTyVars tc_name tvs $ \ tvs' kind -> 
     tcTySynRhs tc_name tvs' kind rhs
 
   -- "data/newtype" declaration
-tcTyClDecl1 _parent calc_isrec
+tcTyClDecl1 _parent rec_info
             (DataDecl { tcdLName = L _ tc_name, tcdTyVars = tvs, tcdDataDefn = defn })
   = ASSERT( isNoParent _parent )
     tcTyClTyVars tc_name tvs $ \ tvs' kind -> 
-    tcDataDefn calc_isrec tc_name tvs' kind defn
+    tcDataDefn rec_info tc_name tvs' kind defn
 
-tcTyClDecl1 _parent calc_isrec
+tcTyClDecl1 _parent rec_info
             (ClassDecl { tcdLName = L _ class_name, tcdTyVars = tvs
             , tcdCtxt = ctxt, tcdMeths = meths
 	    , tcdFDs = fundeps, tcdSigs = sigs
@@ -603,7 +603,7 @@ tcTyClDecl1 _parent calc_isrec
 			-- hold of the name of the class TyCon, which we
 			-- need to look up its recursiveness
 		    tycon_name = tyConName (classTyCon clas)
-		    tc_isrec = calc_isrec tycon_name
+		    tc_isrec = rti_is_rec rec_info tycon_name
 
                ; ctxt' <- tcHsContext ctxt
                ; ctxt' <- zonkTcTypeToTypes emptyZonkEnv ctxt'  
@@ -667,7 +667,10 @@ tcFamDecl1 parent
   ; extra_tvs <- tcDataKindSig kind
   ; let final_tvs = tvs' ++ extra_tvs    -- we may not need these
         tycon = buildAlgTyCon tc_name final_tvs Nothing []
-                              DataFamilyTyCon Recursive True parent
+                              DataFamilyTyCon Recursive 
+                              False   -- Not promotable to the kind level
+                              True    -- GADT syntax
+                              parent
   ; return [ATyCon tycon] }
 
 tcTySynRhs :: Name   
@@ -682,17 +685,16 @@ tcTySynRhs tc_name tvs kind hs_ty
                                 kind NoParentTyCon
        ; return [ATyCon tycon] }
 
-tcDataDefn :: (Name -> RecFlag) -> Name
+tcDataDefn :: RecTyInfo -> Name
            -> [TyVar] -> Kind
            -> HsDataDefn Name -> TcM [TyThing]
   -- NB: not used for newtype/data instances (whether associated or not)
-tcDataDefn calc_isrec tc_name tvs kind
+tcDataDefn rec_info tc_name tvs kind
          (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
                      , dd_ctxt = ctxt, dd_kindSig = mb_ksig
                      , dd_cons = cons })
   = do { extra_tvs <- tcDataKindSig kind
-       ; let is_rec     = calc_isrec tc_name
-             final_tvs  = tvs ++ extra_tvs
+       ; let final_tvs  = tvs ++ extra_tvs
        ; stupid_theta <- tcHsContext ctxt
        ; kind_signatures <- xoptM Opt_KindSignatures
        ; is_boot	 <- tcIsHsBoot	-- Are we compiling an hs-boot file?
@@ -718,7 +720,9 @@ tcDataDefn calc_isrec tc_name tvs kind
              	   NewType  -> ASSERT( not (null data_cons) )
                                     mkNewTyConRhs tc_name tycon (head data_cons)
              ; return (buildAlgTyCon tc_name final_tvs cType stupid_theta tc_rhs
-                                     is_rec (not h98_syntax) NoParentTyCon) }
+                                     (rti_is_rec rec_info tc_name)
+                                     (rti_promotable rec_info)
+                                     (not h98_syntax) NoParentTyCon) }
        ; return [ATyCon tycon] }
 \end{code}
 
diff --git a/compiler/typecheck/TcTyDecls.lhs b/compiler/typecheck/TcTyDecls.lhs
index 6818c025a2..99ee065e2d 100644
--- a/compiler/typecheck/TcTyDecls.lhs
+++ b/compiler/typecheck/TcTyDecls.lhs
@@ -17,7 +17,7 @@ files for imported data types.
 -- for details
 
 module TcTyDecls(
-        calcRecFlags,
+        calcRecFlags, RecTyInfo(..), 
         calcSynCycles, calcClassCycles
     ) where
 
@@ -27,9 +27,11 @@ import TypeRep
 import HsSyn
 import Class
 import Type
+import Kind
 import HscTypes
 import TyCon
 import DataCon
+import Var
 import Name
 import NameEnv
 import NameSet
@@ -38,8 +40,8 @@ import Digraph
 import BasicTypes
 import SrcLoc
 import UniqSet
-import Maybes( mapCatMaybes )
-import Util ( isSingleton )
+import Maybes( mapCatMaybes, isJust )
+import Util ( lengthIs, isSingleton )
 import Data.List
 \end{code}
 
@@ -348,12 +350,24 @@ recursiveness, because we need only look at the type decls in the module being
 compiled, plus the outer structure of directly-mentioned types.
 
 \begin{code}
-calcRecFlags :: ModDetails -> [TyThing] -> (Name -> RecFlag)
+data RecTyInfo = RTI { rti_promotable :: Bool
+                     , rti_is_rec     :: Name -> RecFlag }
+
+calcRecFlags :: ModDetails -> [TyThing] -> RecTyInfo
 -- The 'boot_names' are the things declared in M.hi-boot, if M is the current module.
 -- Any type constructors in boot_names are automatically considered loop breakers
 calcRecFlags boot_details tyclss
-  = is_rec
+  = RTI { rti_promotable = is_promotable
+        , rti_is_rec     = is_rec }
   where
+    rec_tycon_names = mkNameSet (map tyConName all_tycons)
+    all_tycons = mapCatMaybes getTyCon tyclss
+                   -- Recursion of newtypes/data types can happen via
+                   -- the class TyCon, so tyclss includes the class tycons
+
+    is_promotable = all (isPromotableTyCon rec_tycon_names) all_tycons
+
+    ----------------- Recursion calculation ----------------
     is_rec n | n `elemNameSet` rec_names = Recursive
              | otherwise                 = NonRecursive
 
@@ -362,12 +376,6 @@ calcRecFlags boot_details tyclss
                 nt_loop_breakers  `unionNameSets`
                 prod_loop_breakers
 
-    all_tycons = [ tc | tc <- mapCatMaybes getTyCon tyclss
-                           -- Recursion of newtypes/data types can happen via
-                           -- the class TyCon, so tyclss includes the class tycons
-                      , not (tyConName tc `elemNameSet` boot_name_set) ]
-                           -- Remove the boot_name_set because they are going
-                           -- to be loop breakers regardless.
 
         -------------------------------------------------
         --                      NOTE
@@ -379,8 +387,13 @@ calcRecFlags boot_details tyclss
         -- loop.  We could program round this, but it'd make the code
         -- rather less nice, so I'm not going to do that yet.
 
-    single_con_tycons = filter (isSingleton . tyConDataCons) all_tycons
+    single_con_tycons = [ tc | tc <- all_tycons
+                             , not (tyConName tc `elemNameSet` boot_name_set)
+                                 -- Remove the boot_name_set because they are 
+                                 -- going to be loop breakers regardless.
+                             , isSingleton (tyConDataCons tc) ]
         -- Both newtypes and data types, with exactly one data constructor
+
     (new_tycons, prod_tycons) = partition isNewTyCon single_con_tycons
         -- NB: we do *not* call isProductTyCon because that checks
 	--     for vanilla-ness of data constructors; and that depends
@@ -443,6 +456,80 @@ findLoopBreakers deps
                  name <- tyConName tc : go edges']
 \end{code}
 
+
+%************************************************************************
+%*                                                                      *
+                  Promotion calculation
+%*                                                                      *
+%************************************************************************
+
+See Note [Checking whether a group is promotable]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We only want to promote a TyCon if all its data constructors
+are promotable; it'd be very odd to promote some but not others.
+
+But the data constructors may mention this or other TyCons.
+
+So we treat the recursive uses as all OK (ie promotable) and
+do one pass to check that each TyCon is promotable.
+
+Currently type synonyms are not promotable, though that
+could change.
+
+\begin{code}
+isPromotableTyCon :: NameSet -> TyCon -> Bool
+isPromotableTyCon rec_tycons tc
+  =  isAlgTyCon tc    -- Only algebraic; not even synonyms
+                     -- (we could reconsider the latter)
+  && ok_kind (tyConKind tc)
+  && case algTyConRhs tc of 
+       DataTyCon { data_cons = cs } -> all ok_con cs 
+       NewTyCon { data_con = c }    -> ok_con c
+       AbstractTyCon {}             -> False
+       DataFamilyTyCon {}           -> False
+
+  where
+    ok_kind kind = all isLiftedTypeKind args && isLiftedTypeKind res
+            where  -- Checks for * -> ... -> * -> *
+              (args, res) = splitKindFunTys kind
+
+    -- See Note [Promoted data constructors] in TyCon
+    ok_con con = all (isLiftedTypeKind . tyVarKind) ex_tvs
+              && null eq_spec   -- No constraints
+              && null theta
+              && all (isPromotableType rec_tycons) orig_arg_tys
+       where
+         (_, ex_tvs, eq_spec, theta, orig_arg_tys, _) = dataConFullSig con
+
+
+isPromotableType :: NameSet -> Type -> Bool
+-- Must line up with DataCon.promoteType
+-- But the function lives here because we must treat the
+-- *recursive* tycons as promotable
+isPromotableType rec_tcs ty
+  = case splitForAllTys ty of
+      (_, rho) -> go rho
+  where
+    go (TyConApp tc tys) 
+      | tys `lengthIs` tyConArity tc 
+      ,  tyConName tc `elemNameSet` rec_tcs 
+      || isJust (promotableTyCon_maybe tc) 
+                       = all go tys
+      | otherwise      = False
+    go (FunTy arg res) = go arg && go res
+    go (AppTy arg res) = go arg && go res
+    go (ForAllTy _ ty) = go ty
+    go (TyVarTy {})    = True
+    go (LitTy {})      = False
+\end{code}
+
+
+%************************************************************************
+%*                                                                      *
+        Miscellaneous funcions
+%*                                                                      *
+%************************************************************************
+
 These two functions know about type representations, so they could be
 in Type or TcType -- but they are very specialised to this module, so
 I've chosen to put them here.
diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs
index 0bce4db43e..86202a3ef5 100644
--- a/compiler/types/TyCon.lhs
+++ b/compiler/types/TyCon.lhs
@@ -39,6 +39,7 @@ module TyCon(
         isForeignTyCon, 
         isPromotedDataCon, isPromotedTyCon,
         isPromotedDataCon_maybe, isPromotedTyCon_maybe,
+        promotableTyCon_maybe, promoteTyCon,
 
         isInjectiveTyCon,
         isDataTyCon, isProductTyCon, isEnumerationTyCon,
@@ -333,10 +334,12 @@ data TyCon
         algTcRec :: RecFlag,      -- ^ Tells us whether the data type is part
                                   -- of a mutually-recursive group or not
 
-        algTcParent :: TyConParent      -- ^ Gives the class or family declaration 'TyCon'
+        algTcParent :: TyConParent,     -- ^ Gives the class or family declaration 'TyCon'
                                         -- for derived 'TyCon's representing class
                                         -- or family instances, respectively.
                                         -- See also 'synTcParent'
+        
+        tcPromoted :: Maybe TyCon    -- ^ Promoted TyCon, if any
     }
 
   -- | Represents the infinite family of tuple type constructors,
@@ -348,7 +351,8 @@ data TyCon
         tyConArity     :: Arity,
         tyConTupleSort :: TupleSort,
         tyConTyVars    :: [TyVar],
-        dataCon        :: DataCon -- ^ Corresponding tuple data constructor
+        dataCon        :: DataCon, -- ^ Corresponding tuple data constructor
+        tcPromoted     :: Maybe TyCon    -- Nothing for unboxed tuples
     }
 
   -- | Represents type synonyms
@@ -837,8 +841,9 @@ mkAlgTyCon :: Name
            -> TyConParent
            -> RecFlag           -- ^ Is the 'TyCon' recursive?
            -> Bool              -- ^ Was the 'TyCon' declared with GADT syntax?
+           -> Maybe TyCon       -- ^ Promoted version
            -> TyCon
-mkAlgTyCon name kind tyvars cType stupid rhs parent is_rec gadt_syn
+mkAlgTyCon name kind tyvars cType stupid rhs parent is_rec gadt_syn prom_tc
   = AlgTyCon {
         tyConName        = name,
         tyConUnique      = nameUnique name,
@@ -850,22 +855,26 @@ mkAlgTyCon name kind tyvars cType stupid rhs parent is_rec gadt_syn
         algTcRhs         = rhs,
         algTcParent      = ASSERT2( okParent name parent, ppr name $$ ppr parent ) parent,
         algTcRec         = is_rec,
-        algTcGadtSyntax  = gadt_syn
+        algTcGadtSyntax  = gadt_syn,
+        tcPromoted       = prom_tc
     }
 
 -- | Simpler specialization of 'mkAlgTyCon' for classes
 mkClassTyCon :: Name -> Kind -> [TyVar] -> AlgTyConRhs -> Class -> RecFlag -> TyCon
-mkClassTyCon name kind tyvars rhs clas is_rec =
-  mkAlgTyCon name kind tyvars Nothing [] rhs (ClassTyCon clas) is_rec False
+mkClassTyCon name kind tyvars rhs clas is_rec
+  = mkAlgTyCon name kind tyvars Nothing [] rhs (ClassTyCon clas) 
+               is_rec False 
+               Nothing    -- Class TyCons are not pormoted
 
 mkTupleTyCon :: Name
              -> Kind    -- ^ Kind of the resulting 'TyCon'
              -> Arity   -- ^ Arity of the tuple
              -> [TyVar] -- ^ 'TyVar's scoped over: see 'tyConTyVars'
              -> DataCon
-             -> TupleSort  -- ^ Whether the tuple is boxed or unboxed
+             -> TupleSort    -- ^ Whether the tuple is boxed or unboxed
+             -> Maybe TyCon  -- ^ Promoted version
              -> TyCon
-mkTupleTyCon name kind arity tyvars con sort
+mkTupleTyCon name kind arity tyvars con sort prom_tc
   = TupleTyCon {
         tyConUnique = nameUnique name,
         tyConName = name,
@@ -873,7 +882,8 @@ mkTupleTyCon name kind arity tyvars con sort
         tyConArity = arity,
         tyConTupleSort = sort,
         tyConTyVars = tyvars,
-        dataCon = con
+        dataCon = con,
+        tcPromoted = prom_tc
     }
 
 -- ^ Foreign-imported (.NET) type constructors are represented
@@ -1186,6 +1196,16 @@ isRecursiveTyCon :: TyCon -> Bool
 isRecursiveTyCon (AlgTyCon {algTcRec = Recursive}) = True
 isRecursiveTyCon _                                 = False
 
+promotableTyCon_maybe :: TyCon -> Maybe TyCon
+promotableTyCon_maybe (AlgTyCon { tcPromoted = prom })   = prom
+promotableTyCon_maybe (TupleTyCon { tcPromoted = prom }) = prom
+promotableTyCon_maybe _                                  = Nothing
+
+promoteTyCon :: TyCon -> TyCon
+promoteTyCon tc = case promotableTyCon_maybe tc of
+                    Just prom_tc -> prom_tc
+                    Nothing      -> pprPanic "promoteTyCon" (ppr tc)
+
 -- | Is this the 'TyCon' of a foreign-imported type constructor?
 isForeignTyCon :: TyCon -> Bool
 isForeignTyCon (PrimTyCon {tyConExtName = Just _}) = True
diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs
index efe8a3bde3..cbff4fa7df 100644
--- a/compiler/types/Type.lhs
+++ b/compiler/types/Type.lhs
@@ -154,7 +154,7 @@ import VarSet
 import Class
 import TyCon
 import TysPrim
-import {-# SOURCE #-} TysWiredIn ( eqTyCon, typeNatKind, typeStringKind )
+import {-# SOURCE #-} TysWiredIn ( eqTyCon, typeNatKind, typeSymbolKind )
 import PrelNames ( eqTyConKey, ipClassNameKey, 
                    constraintKindTyConKey, liftedTypeKindTyConKey )
 import CoAxiom
@@ -1630,7 +1630,7 @@ typeLiteralKind :: TyLit -> Kind
 typeLiteralKind l =
   case l of
     NumTyLit _ -> typeNatKind
-    StrTyLit _ -> typeStringKind
+    StrTyLit _ -> typeSymbolKind
 \end{code}
 
 Kind inference
diff --git a/compiler/utils/Platform.hs b/compiler/utils/Platform.hs
index 661e03a3a5..090ce41f30 100644
--- a/compiler/utils/Platform.hs
+++ b/compiler/utils/Platform.hs
@@ -70,6 +70,7 @@ data OS
         | OSHaiku
         | OSOsf3
         | OSQNXNTO
+        | OSAndroid
         deriving (Read, Show, Eq)
 
 -- | ARM Instruction Set Architecture, Extensions and ABI
@@ -112,6 +113,7 @@ osElfTarget OSHaiku     = True
 osElfTarget OSOsf3      = False -- I don't know if this is right, but as
                                 -- per comment below it's safe
 osElfTarget OSQNXNTO    = False
+osElfTarget OSAndroid   = True
 osElfTarget OSUnknown   = False
  -- Defaulting to False is safe; it means don't rely on any
  -- ELF-specific functionality.  It is important to have a default for
diff --git a/compiler/vectorise/Vectorise/Generic/PData.hs b/compiler/vectorise/Vectorise/Generic/PData.hs
index 295a4805a6..cbedf8d8e0 100644
--- a/compiler/vectorise/Vectorise/Generic/PData.hs
+++ b/compiler/vectorise/Vectorise/Generic/PData.hs
@@ -54,6 +54,7 @@ buildDataFamInst name' fam_tc vect_tc rhs
                            []          -- no stupid theta
                            rhs
                            rec_flag    -- FIXME: is this ok?
+                           False       -- Not promotable
                            False       -- not GADT syntax
                            (FamInstTyCon ax fam_tc pat_tys)
       ; return fam_inst }
diff --git a/compiler/vectorise/Vectorise/Type/TyConDecl.hs b/compiler/vectorise/Vectorise/Type/TyConDecl.hs
index d1c5ca53b1..588cd39ec0 100644
--- a/compiler/vectorise/Vectorise/Type/TyConDecl.hs
+++ b/compiler/vectorise/Vectorise/Type/TyConDecl.hs
@@ -104,6 +104,7 @@ vectTyConDecl tycon name'
                     []                      -- no stupid theta
                     rhs'                    -- new constructor defs
                     rec_flag                -- whether recursive
+                    False                   -- Not promotable
                     gadt_flag               -- whether in GADT syntax
                     NoParentTyCon           
        }