Commit 503b2650 authored by Simon Peyton Jones's avatar Simon Peyton Jones

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

parents 6d48e903 d5952932
......@@ -893,7 +893,7 @@ AC_SUBST(Alex3)
AC_DEFUN([FP_PROG_LD_FLAG],
[
AC_CACHE_CHECK([whether ld understands $1], [fp_cv_$2],
[echo 'foo() {}' > conftest.c
[echo 'int foo() { return 0; }' > conftest.c
${CC-cc} -c conftest.c
if ${LdCmd} -r $1 -o conftest2.o conftest.o > /dev/null 2>&1; then
fp_cv_$2=$1
......@@ -934,7 +934,7 @@ FP_PROG_LD_FLAG([--reduce-memory-overheads],[LdReduceMemoryOverheads])
AC_DEFUN([FP_PROG_LD_BUILD_ID],
[
AC_CACHE_CHECK([whether ld understands --build-id], [fp_cv_ld_build_id],
[echo 'foo() {}' > conftest.c
[echo 'int foo() { return 0; }' > conftest.c
${CC-cc} -c conftest.c
if ${LdCmd} -r --build-id=none -o conftest2.o conftest.o > /dev/null 2>&1; then
fp_cv_ld_build_id=yes
......@@ -975,7 +975,7 @@ AC_SUBST([LdIsGNULd], [`echo $fp_cv_gnu_ld | sed 'y/yesno/YESNO/'`])
AC_DEFUN([FP_PROG_LD_NO_COMPACT_UNWIND],
[
AC_CACHE_CHECK([whether ld understands -no_compact_unwind], [fp_cv_ld_no_compact_unwind],
[echo 'foo() {}' > conftest.c
[echo 'int foo() { return 0; }' > conftest.c
${CC-cc} -c conftest.c
if ${LdCmd} -r -no_compact_unwind -o conftest2.o conftest.o > /dev/null 2>&1; then
fp_cv_ld_no_compact_unwind=yes
......@@ -1136,19 +1136,30 @@ AC_SUBST(GccLT34)
AC_SUBST(GccLT46)
])# FP_GCC_VERSION
dnl Check to see if the C compiler uses an LLVM back end
dnl Check to see if the C compiler is clang or llvm-gcc
dnl
AC_DEFUN([FP_CC_LLVM_BACKEND],
[AC_REQUIRE([AC_PROG_CC])
AC_MSG_CHECKING([whether C compiler has an LLVM back end])
AC_MSG_CHECKING([whether C compiler is clang])
$CC -x c /dev/null -dM -E > conftest.txt 2>&1
if grep "__llvm__" conftest.txt >/dev/null 2>&1; then
if grep "__clang__" conftest.txt >/dev/null 2>&1; then
AC_SUBST([CC_CLANG_BACKEND], [1])
AC_SUBST([CC_LLVM_BACKEND], [1])
AC_MSG_RESULT([yes])
else
AC_SUBST([CC_LLVM_BACKEND], [0])
AC_MSG_RESULT([no])
AC_MSG_CHECKING([whether C compiler has an LLVM back end])
if grep "__llvm__" conftest.txt >/dev/null 2>&1; then
AC_SUBST([CC_CLANG_BACKEND], [0])
AC_SUBST([CC_LLVM_BACKEND], [1])
AC_MSG_RESULT([yes])
else
AC_SUBST([CC_CLANG_BACKEND], [0])
AC_SUBST([CC_LLVM_BACKEND], [0])
AC_MSG_RESULT([no])
fi
fi
rm -f conftest.txt
])
......
......@@ -14,7 +14,7 @@
{-# LANGUAGE TypeFamilies #-}
module TrieMap(
CoreMap, emptyCoreMap, extendCoreMap, lookupCoreMap, foldCoreMap,
TypeMap, foldTypeMap, lookupTypeMap_mod,
TypeMap, foldTypeMap, -- lookupTypeMap_mod,
CoercionMap,
MaybeMap,
ListMap,
......@@ -32,8 +32,6 @@ import UniqFM
import Unique( Unique )
import FastString(FastString)
import Unify ( niFixTvSubst )
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
import VarEnv
......@@ -632,40 +630,6 @@ lkT env ty m
go (ForAllTy tv ty) = tm_forall >.> lkT (extendCME env tv) ty >=> lkBndr env tv
lkT_mod :: CmEnv
-> TyVarEnv Type -- TvSubstEnv
-> Type
-> TypeMap b -> Maybe b
lkT_mod env s ty m
| EmptyTM <- m = Nothing
| Just ty' <- coreView ty
= lkT_mod env s ty' m
| [] <- candidates
= go env s ty m
| otherwise
= Just $ snd (head candidates) -- Yikes!
where
-- Hopefully intersects is much smaller than traversing the whole vm_fvar
intersects = eltsUFM $
intersectUFM_C (,) s (vm_fvar $ tm_var m)
candidates = [ (u,ct) | (u,ct) <- intersects
, Type.substTy (niFixTvSubst s) u `eqType` ty ]
go env _s (TyVarTy v) = tm_var >.> lkVar env v
go env s (AppTy t1 t2) = tm_app >.> lkT_mod env s t1 >=> lkT_mod env s t2
go env s (FunTy t1 t2) = tm_fun >.> lkT_mod env s t1 >=> lkT_mod env s t2
go env s (TyConApp tc tys) = tm_tc_app >.> lkNamed tc >=> lkList (lkT_mod env s) tys
go _env _s (LitTy l) = tm_tylit >.> lkTyLit l
go _env _s (ForAllTy _tv _ty) = const Nothing
{- DV TODO: Add proper lookup for ForAll -}
lookupTypeMap_mod :: TyVarEnv a -- A substitution to be applied to the /keys/ of type map
-> (a -> Type)
-> Type
-> TypeMap b -> Maybe b
lookupTypeMap_mod s f = lkT_mod emptyCME (mapVarEnv f s)
-----------------
xtT :: CmEnv -> Type -> XT a -> TypeMap a -> TypeMap a
xtT env ty f m
......
......@@ -920,7 +920,8 @@ repE (HsLit l) = do { a <- repLiteral l; repLit a }
repE (HsLam (MG { mg_alts = [m] })) = repLambda m
repE (HsLamCase _ (MG { mg_alts = ms }))
= do { ms' <- mapM repMatchTup ms
; repLamCase (nonEmptyCoreList ms') }
; core_ms <- coreList matchQTyConName ms'
; repLamCase core_ms }
repE (HsApp x y) = do {a <- repLE x; b <- repLE y; repApp a b}
repE (OpApp e1 op _ e2) =
......@@ -938,7 +939,8 @@ repE (SectionR x y) = do { a <- repLE x; b <- repLE y; repSectionR a b }
repE (HsCase e (MG { mg_alts = ms }))
= do { arg <- repLE e
; ms2 <- mapM repMatchTup ms
; repCaseE arg (nonEmptyCoreList ms2) }
; core_ms2 <- coreList matchQTyConName ms2
; repCaseE arg core_ms2 }
repE (HsIf _ x y z) = do
a <- repLE x
b <- repLE y
......
......@@ -524,9 +524,7 @@ cvtl e = wrapL (cvt e)
cvt (AppE x y) = do { x' <- cvtl x; y' <- cvtl y; return $ HsApp x' y' }
cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e
; return $ HsLam (mkMatchGroup [mkSimpleMatch ps' e']) }
cvt (LamCaseE ms)
| null ms = failWith (ptext (sLit "Lambda-case expression with no alternatives"))
| otherwise = do { ms' <- mapM cvtMatch ms
cvt (LamCaseE ms) = do { ms' <- mapM cvtMatch ms
; return $ HsLamCase placeHolderType
(mkMatchGroup ms')
}
......@@ -543,9 +541,7 @@ cvtl e = wrapL (cvt e)
; return $ HsMultiIf placeHolderType alts' }
cvt (LetE ds e) = do { ds' <- cvtLocalDecs (ptext (sLit "a let expression")) ds
; e' <- cvtl e; return $ HsLet ds' e' }
cvt (CaseE e ms)
| null ms = failWith (ptext (sLit "Case expression with no alternatives"))
| otherwise = do { e' <- cvtl e; ms' <- mapM cvtMatch ms
cvt (CaseE e ms) = do { e' <- cvtl e; ms' <- mapM cvtMatch ms
; return $ HsCase e' (mkMatchGroup ms') }
cvt (DoE ss) = cvtHsDo DoExpr ss
cvt (CompE ss) = cvtHsDo ListComp ss
......
\begin{code}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE CPP, KindSignatures #-}
module HsExpr where
import SrcLoc ( Located )
......@@ -8,22 +8,29 @@ import {-# SOURCE #-} HsPat ( LPat )
import Data.Data
-- IA0_NOTE: We need kind annotations because of kind polymorphism
data HsExpr (i :: *)
data HsCmd (i :: *)
data HsSplice (i :: *)
data MatchGroup (a :: *) (body :: *)
data GRHSs (a :: *) (body :: *)
#if __GLASGOW_HASKELL__ > 706
instance Typeable HsSplice
instance Typeable HsExpr
instance Typeable MatchGroup
instance Typeable GRHSs
#else
instance Typeable1 HsSplice
instance Data i => Data (HsSplice i)
instance Typeable1 HsExpr
instance Data i => Data (HsExpr i)
instance Typeable1 HsCmd
instance Data i => Data (HsCmd i)
instance Typeable2 MatchGroup
instance (Data i, Data body) => Data (MatchGroup i body)
instance Typeable2 GRHSs
#endif
instance Data i => Data (HsSplice i)
instance Data i => Data (HsExpr i)
instance Data i => Data (HsCmd i)
instance (Data i, Data body) => Data (MatchGroup i body)
instance (Data i, Data body) => Data (GRHSs i body)
instance OutputableBndr id => Outputable (HsExpr id)
......
\begin{code}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE CPP, KindSignatures #-}
module HsPat where
import SrcLoc( Located )
import Data.Data
-- IA0_NOTE: We need kind annotation because of kind polymorphism.
data Pat (i :: *)
type LPat i = Located (Pat i)
#if __GLASGOW_HASKELL__ > 706
instance Typeable Pat
#else
instance Typeable1 Pat
#endif
instance Data i => Data (Pat i)
\end{code}
......@@ -428,6 +428,7 @@ data WarningFlag =
| Opt_WarnUnsupportedCallingConventions
| Opt_WarnUnsupportedLlvmVersion
| Opt_WarnInlineRuleShadowing
| Opt_WarnTypeableInstances
deriving (Eq, Show, Enum)
data Language = Haskell98 | Haskell2010
......@@ -495,6 +496,7 @@ data ExtensionFlag
| Opt_StandaloneDeriving
| Opt_DeriveDataTypeable
| Opt_AutoDeriveTypeable -- Automatic derivation of Typeable
| Opt_DeriveFunctor
| Opt_DeriveTraversable
| Opt_DeriveFoldable
......@@ -2400,7 +2402,8 @@ fWarningFlags = [
( "warn-pointless-pragmas", Opt_WarnPointlessPragmas, nop ),
( "warn-unsupported-calling-conventions", Opt_WarnUnsupportedCallingConventions, nop ),
( "warn-inline-rule-shadowing", Opt_WarnInlineRuleShadowing, nop ),
( "warn-unsupported-llvm-version", Opt_WarnUnsupportedLlvmVersion, nop ) ]
( "warn-unsupported-llvm-version", Opt_WarnUnsupportedLlvmVersion, nop ),
( "warn-typeable-instances", Opt_WarnTypeableInstances, nop ) ]
-- | These @-\<blah\>@ flags can all be reversed with @-no-\<blah\>@
negatableFlags :: [FlagSpec GeneralFlag]
......@@ -2631,6 +2634,7 @@ xFlags = [
( "UnboxedTuples", Opt_UnboxedTuples, nop ),
( "StandaloneDeriving", Opt_StandaloneDeriving, nop ),
( "DeriveDataTypeable", Opt_DeriveDataTypeable, nop ),
( "AutoDeriveTypeable", Opt_AutoDeriveTypeable, nop ),
( "DeriveFunctor", Opt_DeriveFunctor, nop ),
( "DeriveTraversable", Opt_DeriveTraversable, nop ),
( "DeriveFoldable", Opt_DeriveFoldable, nop ),
......@@ -2788,7 +2792,9 @@ standardWarnings
Opt_WarnUnsupportedCallingConventions,
Opt_WarnUnsupportedLlvmVersion,
Opt_WarnInlineRuleShadowing,
Opt_WarnDuplicateConstraints
Opt_WarnDuplicateConstraints,
Opt_WarnInlineRuleShadowing,
Opt_WarnTypeableInstances
]
minusWOpts :: [WarningFlag]
......
......@@ -41,6 +41,9 @@ import FastBool
import UniqFM (listToUFM, lookupUFM)
import UniqSupply
import Control.Monad (replicateM)
import Data.Maybe (fromMaybe)
--------------------------------------------------------------------------------
-- Size of a PPC memory address, in bytes.
--
......@@ -80,6 +83,9 @@ ppc_mkStackDeallocInstr platform amount
ADD sp sp (RIImm (ImmInt amount))
arch -> panic $ "ppc_mkStackDeallocInstr " ++ show arch
--
-- See note [extra spill slots] in X86/Instr.hs
--
allocMoreStack
:: Platform
-> Int
......@@ -87,32 +93,61 @@ allocMoreStack
-> UniqSM (NatCmmDecl statics PPC.Instr.Instr)
allocMoreStack _ _ top@(CmmData _ _) = return top
allocMoreStack platform amount (CmmProc info lbl live (ListGraph code)) =
return (CmmProc info lbl live (ListGraph (map insert_stack_insns code)))
where
alloc = mkStackAllocInstr platform amount
dealloc = mkStackDeallocInstr platform amount
is_entry_point id = id `mapMember` info
insert_stack_insns (BasicBlock id insns)
| is_entry_point id = BasicBlock id (alloc : block')
| otherwise = BasicBlock id block'
where
block' = insertBeforeNonlocalTransfers dealloc insns
insertBeforeNonlocalTransfers :: Instr -> [Instr] -> [Instr]
insertBeforeNonlocalTransfers insert insns
= foldr p [] insns
where p insn r = case insn of
BCC _ _ -> insert : insn : r
BCCFAR _ _ -> insert : insn : r
JMP _ -> insert : insn : r
MTCTR _ -> insert : insn : r
BCTR _ _ -> insert : insn : r
BL _ _ -> insert : insn : r
BCTRL _ -> insert : insn : r
_ -> insn : r
allocMoreStack platform slots (CmmProc info lbl live (ListGraph code)) = do
let
infos = mapKeys info
entries = case code of
[] -> infos
BasicBlock entry _ : _ -- first block is the entry point
| entry `elem` infos -> infos
| otherwise -> entry : infos
uniqs <- replicateM (length entries) getUniqueUs
let
delta = ((x + stackAlign - 1) `quot` stackAlign) * stackAlign -- round up
where x = slots * spillSlotSize -- sp delta
alloc = mkStackAllocInstr platform delta
dealloc = mkStackDeallocInstr platform delta
new_blockmap :: BlockEnv BlockId
new_blockmap = mapFromList (zip entries (map mkBlockId uniqs))
insert_stack_insns (BasicBlock id insns)
| Just new_blockid <- mapLookup id new_blockmap
= [ BasicBlock id [alloc, BCC ALWAYS new_blockid]
, BasicBlock new_blockid block'
]
| otherwise
= [ BasicBlock id block' ]
where
block' = foldr insert_dealloc [] insns
insert_dealloc insn r
-- BCTR might or might not be a non-local jump. For
-- "labeled-goto" we use JMP, and for "computed-goto" we
-- use MTCTR followed by BCTR. See 'PPC.CodeGen.genJump'.
= case insn of
JMP _ -> dealloc : insn : r
BCTR [] Nothing -> dealloc : insn : r
BCTR ids label -> BCTR (map (fmap retarget) ids) label : r
BCCFAR cond b -> BCCFAR cond (retarget b) : r
BCC cond b -> BCC cond (retarget b) : r
_ -> insn : r
-- BL and BCTRL are call-like instructions rather than
-- jumps, and are used only for C calls.
retarget :: BlockId -> BlockId
retarget b
= fromMaybe b (mapLookup b new_blockmap)
new_code
= concatMap insert_stack_insns code
-- in
return (CmmProc info lbl live (ListGraph new_code))
-- -----------------------------------------------------------------------------
-- Machine's assembly language
......@@ -412,7 +447,7 @@ ppc_mkSpillInstr
ppc_mkSpillInstr dflags reg delta slot
= let platform = targetPlatform dflags
off = spillSlotToOffset dflags slot
off = spillSlotToOffset slot
in
let sz = case targetClassOfReg platform reg of
RcInteger -> II32
......@@ -430,7 +465,7 @@ ppc_mkLoadInstr
ppc_mkLoadInstr dflags reg delta slot
= let platform = targetPlatform dflags
off = spillSlotToOffset dflags slot
off = spillSlotToOffset slot
in
let sz = case targetClassOfReg platform reg of
RcInteger -> II32
......@@ -439,20 +474,31 @@ ppc_mkLoadInstr dflags reg delta slot
in LD sz reg (AddrRegImm sp (ImmInt (off-delta)))
spillSlotSize :: DynFlags -> Int
spillSlotSize dflags = if is32Bit then 12 else 8
where is32Bit = target32Bit (targetPlatform dflags)
-- | The maximum number of bytes required to spill a register. PPC32
-- has 32-bit GPRs and 64-bit FPRs, while PPC64 has 64-bit GPRs and
-- 64-bit FPRs. So the maximum is 8 regardless of platforms unlike
-- x86. Note that AltiVec's vector registers are 128-bit wide so we
-- must not use this to spill them.
spillSlotSize :: Int
spillSlotSize = 8
-- | The number of spill slots available without allocating more.
maxSpillSlots :: DynFlags -> Int
maxSpillSlots dflags
= ((rESERVED_C_STACK_BYTES dflags - 64) `div` spillSlotSize dflags) - 1
-- convert a spill slot number to a *byte* offset, with no sign:
-- decide on a per arch basis whether you are spilling above or below
-- the C stack pointer.
spillSlotToOffset :: DynFlags -> Int -> Int
spillSlotToOffset dflags slot
= 64 + spillSlotSize dflags * slot
= ((rESERVED_C_STACK_BYTES dflags - 64) `div` spillSlotSize) - 1
-- = 0 -- useful for testing allocMoreStack
-- | The number of bytes that the stack pointer should be aligned
-- to. This is 16 both on PPC32 and PPC64 at least for Darwin, but I'm
-- not sure this is correct for other OSes.
stackAlign :: Int
stackAlign = 16
-- | Convert a spill slot number to a *byte* offset, with no sign.
spillSlotToOffset :: Int -> Int
spillSlotToOffset slot
= 64 + spillSlotSize * slot
--------------------------------------------------------------------------------
-- | See if this instruction is telling us the current C stack delta
......
......@@ -39,6 +39,7 @@ import Unique
import UniqSupply
import Control.Monad
import Data.Maybe (fromMaybe)
-- Size of an x86/x86_64 memory address, in bytes.
--
......@@ -900,9 +901,8 @@ allocMoreStack platform slots (CmmProc info lbl live (ListGraph code)) = do
insert_dealloc insn r = case insn of
JMP _ _ -> dealloc : insn : r
JXX_GBL _ _ -> panic "insert_dealloc: cannot handle JXX_GBL"
JXX cond b | Just new_dest <- mapLookup b new_blockmap
-> JXX cond new_dest : r
_ -> insn : r
_other -> x86_patchJumpInstr insn retarget : r
where retarget b = fromMaybe b (mapLookup b new_blockmap)
new_code = concatMap insert_stack_insns code
-- in
......
......@@ -155,7 +155,7 @@ sharing a unique will be used.
basicKnownKeyNames :: [Name]
basicKnownKeyNames
= genericTyConNames
++ typeableClassNames
++ oldTypeableClassNames
++ [ -- Type constructors (synonyms especially)
ioTyConName, ioDataConName,
runMainIOName,
......@@ -186,6 +186,7 @@ basicKnownKeyNames
applicativeClassName,
foldableClassName,
traversableClassName,
typeableClassName, -- derivable
-- Numeric stuff
negateName, minusName, geName, eqName,
......@@ -350,7 +351,8 @@ gHC_PRIM, gHC_TYPES, gHC_GENERICS,
gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING, dATA_FOLDABLE, dATA_TRAVERSABLE, dATA_MONOID,
gHC_CONC, gHC_IO, gHC_IO_Exception,
gHC_ST, gHC_ARR, gHC_STABLE, gHC_PTR, gHC_ERR, gHC_REAL,
gHC_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC, tYPEABLE, tYPEABLE_INTERNAL, gENERICS,
gHC_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC,
tYPEABLE, tYPEABLE_INTERNAL, oLDTYPEABLE, oLDTYPEABLE_INTERNAL, gENERICS,
dOTNET, rEAD_PREC, lEX, gHC_INT, gHC_WORD, mONAD, mONAD_FIX, mONAD_ZIP,
aRROW, cONTROL_APPLICATIVE, gHC_DESUGAR, rANDOM, gHC_EXTS,
cONTROL_EXCEPTION_BASE, gHC_TYPELITS, gHC_IP :: Module
......@@ -391,6 +393,8 @@ sYSTEM_IO = mkBaseModule (fsLit "System.IO")
dYNAMIC = mkBaseModule (fsLit "Data.Dynamic")
tYPEABLE = mkBaseModule (fsLit "Data.Typeable")
tYPEABLE_INTERNAL = mkBaseModule (fsLit "Data.Typeable.Internal")
oLDTYPEABLE = mkBaseModule (fsLit "Data.OldTypeable")
oLDTYPEABLE_INTERNAL = mkBaseModule (fsLit "Data.OldTypeable.Internal")
gENERICS = mkBaseModule (fsLit "Data.Data")
dOTNET = mkBaseModule (fsLit "GHC.Dotnet")
rEAD_PREC = mkBaseModule (fsLit "Text.ParserCombinators.ReadPrec")
......@@ -617,10 +621,14 @@ showString_RDR = varQual_RDR gHC_SHOW (fsLit "showString")
showSpace_RDR = varQual_RDR gHC_SHOW (fsLit "showSpace")
showParen_RDR = varQual_RDR gHC_SHOW (fsLit "showParen")
typeOf_RDR, mkTyCon_RDR, mkTyConApp_RDR :: RdrName
typeOf_RDR = varQual_RDR tYPEABLE_INTERNAL (fsLit "typeOf")
mkTyCon_RDR = varQual_RDR tYPEABLE_INTERNAL (fsLit "mkTyCon")
mkTyConApp_RDR = varQual_RDR tYPEABLE_INTERNAL (fsLit "mkTyConApp")
typeRep_RDR, mkTyCon_RDR, mkTyConApp_RDR,
oldTypeOf_RDR, oldMkTyCon_RDR, oldMkTyConApp_RDR :: RdrName
typeRep_RDR = varQual_RDR tYPEABLE_INTERNAL (fsLit "typeRep")
mkTyCon_RDR = varQual_RDR tYPEABLE_INTERNAL (fsLit "mkTyCon")
mkTyConApp_RDR = varQual_RDR tYPEABLE_INTERNAL (fsLit "mkTyConApp")
oldTypeOf_RDR = varQual_RDR oLDTYPEABLE_INTERNAL (fsLit "typeOf")
oldMkTyCon_RDR = varQual_RDR oLDTYPEABLE_INTERNAL (fsLit "mkTyCon")
oldMkTyConApp_RDR = varQual_RDR oLDTYPEABLE_INTERNAL (fsLit "mkTyConApp")
undefined_RDR :: RdrName
undefined_RDR = varQual_RDR gHC_ERR (fsLit "undefined")
......@@ -950,22 +958,24 @@ ixClassName :: Name
ixClassName = clsQual gHC_ARR (fsLit "Ix") ixClassKey
-- Class Typeable
typeableClassName, typeable1ClassName, typeable2ClassName,
typeable3ClassName, typeable4ClassName, typeable5ClassName,
typeable6ClassName, typeable7ClassName :: Name
typeableClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable") typeableClassKey
typeable1ClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable1") typeable1ClassKey
typeable2ClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable2") typeable2ClassKey
typeable3ClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable3") typeable3ClassKey
typeable4ClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable4") typeable4ClassKey
typeable5ClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable5") typeable5ClassKey
typeable6ClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable6") typeable6ClassKey
typeable7ClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable7") typeable7ClassKey
typeableClassNames :: [Name]
typeableClassNames = [ typeableClassName, typeable1ClassName, typeable2ClassName
, typeable3ClassName, typeable4ClassName, typeable5ClassName
, typeable6ClassName, typeable7ClassName ]
typeableClassName,
oldTypeableClassName, oldTypeable1ClassName, oldTypeable2ClassName,
oldTypeable3ClassName, oldTypeable4ClassName, oldTypeable5ClassName,
oldTypeable6ClassName, oldTypeable7ClassName :: Name
typeableClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable") typeableClassKey
oldTypeableClassName = clsQual oLDTYPEABLE_INTERNAL (fsLit "Typeable") oldTypeableClassKey
oldTypeable1ClassName = clsQual oLDTYPEABLE_INTERNAL (fsLit "Typeable1") oldTypeable1ClassKey
oldTypeable2ClassName = clsQual oLDTYPEABLE_INTERNAL (fsLit "Typeable2") oldTypeable2ClassKey
oldTypeable3ClassName = clsQual oLDTYPEABLE_INTERNAL (fsLit "Typeable3") oldTypeable3ClassKey
oldTypeable4ClassName = clsQual oLDTYPEABLE_INTERNAL (fsLit "Typeable4") oldTypeable4ClassKey
oldTypeable5ClassName = clsQual oLDTYPEABLE_INTERNAL (fsLit "Typeable5") oldTypeable5ClassKey
oldTypeable6ClassName = clsQual oLDTYPEABLE_INTERNAL (fsLit "Typeable6") oldTypeable6ClassKey
oldTypeable7ClassName = clsQual oLDTYPEABLE_INTERNAL (fsLit "Typeable7") oldTypeable7ClassKey
oldTypeableClassNames :: [Name]
oldTypeableClassNames = [ oldTypeableClassName, oldTypeable1ClassName, oldTypeable2ClassName
, oldTypeable3ClassName, oldTypeable4ClassName, oldTypeable5ClassName
, oldTypeable6ClassName, oldTypeable7ClassName ]
-- Class Data
dataClassName :: Name
......@@ -1231,6 +1241,18 @@ ghciIoClassKey = mkPreludeClassUnique 44
ipClassNameKey :: Unique
ipClassNameKey = mkPreludeClassUnique 45
oldTypeableClassKey, oldTypeable1ClassKey, oldTypeable2ClassKey,
oldTypeable3ClassKey, oldTypeable4ClassKey, oldTypeable5ClassKey,
oldTypeable6ClassKey, oldTypeable7ClassKey :: Unique
oldTypeableClassKey = mkPreludeClassUnique 46
oldTypeable1ClassKey = mkPreludeClassUnique 47
oldTypeable2ClassKey = mkPreludeClassUnique 48
oldTypeable3ClassKey = mkPreludeClassUnique 49
oldTypeable4ClassKey = mkPreludeClassUnique 50
oldTypeable5ClassKey = mkPreludeClassUnique 51
oldTypeable6ClassKey = mkPreludeClassUnique 52
oldTypeable7ClassKey = mkPreludeClassUnique 53
\end{code}
%************************************************************************
......
This diff is collapsed.
......@@ -312,7 +312,15 @@ tcDeriving tycl_decls inst_decls deriv_decls
-- And make the necessary "equations".
is_boot <- tcIsHsBoot
; traceTc "tcDeriving" (ppr is_boot)
; early_specs <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
-- If -XAutoDeriveTypeable is on, add Typeable instances for each
-- datatype and class defined in this module
; isAutoDeriveTypeable <- xoptM Opt_AutoDeriveTypeable
; let deriv_decls' = deriv_decls ++ if isAutoDeriveTypeable
then deriveTypeable tycl_decls
else []
; early_specs <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls'
-- for each type, determine the auxliary declarations that are common
-- to multiple derivations involving that type (e.g. Generic and
......@@ -367,6 +375,12 @@ tcDeriving tycl_decls inst_decls deriv_decls
hangP s x = text "" $$ hang (ptext (sLit s)) 2 x
deriveTypeable :: [LTyClDecl Name] -> [LDerivDecl Name]
deriveTypeable tys =
[ L l (DerivDecl (L l (HsAppTy (noLoc (HsTyVar typeableClassName))
(L l (HsTyVar (tcdName t))))))
| L l t <- tys ]
-- Prints the representable type family instance
pprRepTy :: FamInst Unbranched -> SDoc
pprRepTy fi@(FamInst { fi_branches = FirstBranch (FamInstBranch { fib_lhs = lhs
......@@ -567,6 +581,13 @@ deriveTyData tvs tc tc_args (L loc deriv_pred)
-- The "deriv_pred" is a LHsType to take account of the fact that for
-- newtype deriving we allow deriving (forall a. C [a]).
-- Typeable is special
; if className cls == typeableClassName
then mkEqnHelp DerivOrigin
(varSetElemsKvsFirst (mkVarSet tvs `extendVarSetList` deriv_tvs))
cls cls_tys (mkTyConApp tc tc_args) Nothing
else do {
-- Given data T a b c = ... deriving( C d ),
-- we want to drop type variables from T so that (C d (T a)) is well-kinded
; let cls_tyvars = classTyVars cls
......@@ -604,7 +625,7 @@ deriveTyData tvs tc tc_args (L loc deriv_pred)
; checkTc (not (isFamilyTyCon tc) || n_args_to_drop == 0)
(typeFamilyPapErr tc cls cls_tys inst_ty)
; mkEqnHelp DerivOrigin (varSetElemsKvsFirst univ_tvs) cls cls_tys inst_ty Nothing }
; mkEqnHelp DerivOrigin (varSetElemsKvsFirst univ_tvs) cls cls_tys inst_ty Nothing } }
\end{code}
Note [Deriving, type families, and partial applications]
......@@ -657,7 +678,13 @@ mkEqnHelp orig tvs cls cls_tys tc_app mtheta
bale_out msg = failWithTc (derivingThingErr False cls cls_tys tc_app msg)
mk_alg_eqn tycon tc_args
| className cls `elem` typeableClassNames
| className cls `elem` oldTypeableClassNames
= do { dflags <- getDynFlags
; case checkOldTypeableConditions (dflags, tycon, tc_args) of
Just err -> bale_out err
Nothing -> mk_old_typeable_eqn orig tvs cls tycon tc_args mtheta }
| className cls == typeableClassName
= do { dflags <- getDynFlags
; case checkTypeableConditions (dflags, tycon, tc_args) of
Just err -> bale_out err
......@@ -743,10 +770,10 @@ mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
inst_tys = [mkTyConApp tycon tc_args]
----------------------
mk_typeable_eqn :: CtOrigin -> [TyVar] -> Class
-> TyCon -> [TcType] -> DerivContext
-> TcM EarlyDerivSpec
mk_typeable_eqn orig tvs cls tycon tc_args mtheta
mk_old_typeable_eqn :: CtOrigin -> [TyVar] -> Class
-> TyCon -> [TcType] -> DerivContext
-> TcM EarlyDerivSpec
mk_old_typeable_eqn orig tvs cls tycon tc_args mtheta
-- The Typeable class is special in several ways
-- data T a b = ... deriving( Typeable )
-- gives
......@@ -757,13 +784,13 @@ mk_typeable_eqn orig tvs cls tycon tc_args mtheta
-- 3. The actual class we want to generate isn't necessarily
-- Typeable; it depends on the arity of the type
| isNothing mtheta -- deriving on a data type decl
= do { checkTc (cls `hasKey` typeableClassKey)
= do { checkTc (cls `hasKey` oldTypeableClassKey)
(ptext (sLit "Use deriving( Typeable ) on a data type declaration"))
; real_cls <- tcLookupClass (typeableClassNames `getNth` tyConArity tycon)
; real_cls <- tcLookupClass (oldTypeableClassNames `getNth` tyConArity tycon)
-- See Note [Getting base classes]
; mk_typeable_eqn orig tvs real_cls tycon [] (Just []) }
; mk_old_typeable_eqn orig tvs real_cls tycon [] (Just []) }
| otherwise -- standaone deriving
| otherwise -- standalone deriving
= do { checkTc (null tc_args)
(ptext (sLit "Derived typeable instance must be of form (Typeable")
<> int (tyConArity tycon) <+> ppr tycon <> rparen)
......@@ -775,6 +802,27 @@ mk_typeable_eqn orig tvs cls tycon tc_args mtheta
, ds_tc = tycon, ds_tc_args = []
, ds_theta = mtheta `orElse` [], ds_newtype = False }) }
mk_typeable_eqn :: CtOrigin -> [TyVar] -> Class
-> TyCon -> [TcType] -> DerivContext
-> TcM EarlyDerivSpec
mk_typeable_eqn orig tvs cls tycon tc_args mtheta
-- The kind-polymorphic Typeable class is less special; namely, there is no
-- need to select the class with the right kind anymore, as we only have one.
| isNothing mtheta -- deriving on a data type decl
= mk_typeable_eqn orig tvs cls tycon [] (Just [])
| otherwise -- standalone deriving
= do { checkTc (null tc_args)
(ptext (sLit "Derived typeable instance must be of form (Typeable")
<+> ppr tycon <> rparen)
; dfun_name <- new_dfun_name cls tycon
; loc <- getSrcSpanM
; return (Right $
DS { ds_loc = loc, ds_orig = orig, ds_name = dfun_name, ds_tvs = []
, ds_cls = cls, ds_tys = tyConKind tycon : [mkTyConApp tycon []]
, ds_tc = tycon, ds_tc_args = []
, ds_theta = mtheta `orElse` [], ds_newtype = False }) }
----------------------
inferConstraints :: Class -> [TcType]
-> TyCon -> [TcType]
......@@ -900,8 +948,9 @@ checkSideConditions dflags mtheta cls cls_tys rep_tc rep_tc_args
where
ty_args_why = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "is not a class")
checkTypeableConditions :: Condition
checkTypeableConditions = checkFlag Opt_DeriveDataTypeable `andCond` cond_typeableOK
checkTypeableConditions, checkOldTypeableConditions :: Condition
checkTypeableConditions = checkFlag Opt_DeriveDataTypeable
checkOldTypeableConditions = checkFlag Opt_DeriveDataTypeable `andCond` cond_oldTypeableOK
nonStdErr :: Class -> SDoc
nonStdErr cls = quotes (ppr cls) <+> ptext (sLit "is not a derivable class")
......@@ -1030,11 +1079,11 @@ cond_isProduct (_, rep_tc, _)
why = quotes (pprSourceTyCon rep_tc) <+>
ptext (sLit "must have precisely one constructor")
cond_typeableOK :: Condition
-- OK for Typeable class
cond_oldTypeableOK :: Condition
-- OK for kind-monomorphic Typeable class
-- Currently: (a) args all of kind *
-- (b) 7 or fewer args
cond_typeableOK (_, tc, _)
cond_oldTypeableOK (_, tc, _)
| tyConArity tc > 7 = Just too_many
| not (all (isSubOpenTypeKind . tyVarKind) (tyConTyVars tc))
= Just bad_kind
......@@ -1120,10 +1169,11 @@ non_iso_class :: Class -> Bool
-- even with -XGeneralizedNewtypeDeriving
non_iso_class cls
= classKey cls `elem` ([ readClassKey, showClassKey, dataClassKey
, genClassKey, gen1ClassKey] ++ typeableClassKeys)
, genClassKey, gen1ClassKey, typeableClassKey]
++ oldTypeableClassKeys)
typeableClassKeys :: [Unique]
typeableClassKeys = map getUnique typeableClassNames
oldTypeableClassKeys :: [Unique]
oldTypeableClassKeys = map getUnique oldTypeableClassNames
new_dfun_name :: Class -> TyCon -> TcM Name