Commit 1c4e8962 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

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

parents 82219ae2 a47ee23a
......@@ -251,6 +251,9 @@ AC_DEFUN([FPTOOLS_SET_HASKELL_PLATFORM_VARS],
dragonfly|osf1|hpux|linuxaout|freebsd2|cygwin32|gnu|nextstep2|nextstep3|sunos4|ultrix|irix|aix)
test -z "[$]2" || eval "[$]2=OSUnknown"
;;
linux-android)
test -z "[$]2" || eval "[$]2=OSAndroid"
;;
*)
echo "Unknown OS '[$]1'"
exit 1
......@@ -1821,6 +1824,9 @@ AC_DEFUN([GHC_CONVERT_VENDOR],[
# converts os from gnu to ghc naming, and assigns the result to $target_var
AC_DEFUN([GHC_CONVERT_OS],[
case "$1" in
linux-android*)
$2="linux-android"
;;
linux-*|linux)
$2="linux"
;;
......
......@@ -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
......@@ -994,6 +993,41 @@ dataConCannotMatch tys con
_ -> []
\end{code}
%************************************************************************
%* *
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
......
......@@ -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.
%************************************************************************
%* *
......
......@@ -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
......
......@@ -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
......
......@@ -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")
......
......@@ -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
......
......@@ -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) }
......
......@@ -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
......
......@@ -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
......
......@@ -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"
......
......@@ -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
......
......@@ -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]
......
......@@ -6,6 +6,6 @@ import {-# SOURCE #-} TypeRep (Type)
eqTyCon :: TyCon
typeNatKind, typeStringKind :: Type
typeNatKind, typeSymbolKind :: Type
mkBoxedTupleTy :: [Type] -> Type
\end{code}
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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