diff options
Diffstat (limited to 'compiler')
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 } |