[commit: ghc] ghc-generics1: Merge branch 'master' into ghc-generics1 (28d2952)
José Pedro Magalhães
jpm at cs.uu.nl
Thu May 17 19:16:34 CEST 2012
Repository : ssh://darcs.haskell.org//srv/darcs/ghc
On branch : ghc-generics1
http://hackage.haskell.org/trac/ghc/changeset/28d2952b6d30ba4dde1883267480678a06e936ee
>---------------------------------------------------------------
commit 28d2952b6d30ba4dde1883267480678a06e936ee
Merge: f5f2210... b002f1b...
Author: Jose Pedro Magalhaes <jpm at cs.ox.ac.uk>
Date: Thu May 17 16:58:36 2012 +0100
Merge branch 'master' into ghc-generics1
Conflicts:
compiler/typecheck/TcGenGenerics.lhs
.gitignore | 1 +
aclocal.m4 | 4 +-
bindisttest/Makefile | 4 +-
bindisttest/ghc.mk | 4 +-
compiler/basicTypes/NameEnv.lhs | 32 +-
compiler/basicTypes/SrcLoc.lhs | 7 +-
compiler/cmm/CmmMachOp.hs | 1 +
compiler/cmm/PprC.hs | 52 +-
compiler/codeGen/CgPrimOp.hs | 53 ++
compiler/coreSyn/CoreArity.lhs | 10 +-
compiler/coreSyn/CoreFVs.lhs | 2 +-
compiler/coreSyn/CoreLint.lhs | 8 -
compiler/coreSyn/CoreSyn.lhs | 65 ++-
compiler/coreSyn/CoreUnfold.lhs | 183 ++----
compiler/coreSyn/CoreUtils.lhs | 178 ++++--
compiler/coreSyn/MkCore.lhs | 12 +-
compiler/coreSyn/PprCore.lhs | 4 +-
compiler/coreSyn/TrieMap.lhs | 60 ++-
compiler/deSugar/Coverage.lhs | 14 +-
compiler/deSugar/DsArrows.lhs | 4 +-
compiler/deSugar/DsBinds.lhs | 108 ++--
compiler/deSugar/DsListComp.lhs | 39 +-
compiler/deSugar/DsMeta.hs | 56 +-
compiler/ghc.mk | 6 +-
compiler/ghci/ByteCodeGen.lhs | 3 +
compiler/ghci/LibFFI.hsc | 4 +-
compiler/ghci/RtClosureInspect.hs | 4 +-
compiler/hsSyn/Convert.lhs | 53 +-
compiler/hsSyn/HsDecls.lhs | 60 +-
compiler/hsSyn/HsExpr.lhs | 31 +-
compiler/hsSyn/HsPat.lhs | 4 +-
compiler/hsSyn/HsTypes.lhs | 123 ++--
compiler/hsSyn/HsUtils.lhs | 51 +--
compiler/iface/BinIface.hs | 7 +
compiler/iface/IfaceSyn.lhs | 14 +-
compiler/iface/IfaceType.lhs | 2 +-
compiler/iface/LoadIface.lhs | 2 +-
compiler/iface/MkIface.lhs | 4 +-
compiler/iface/TcIface.lhs | 79 ++-
compiler/llvmGen/LlvmCodeGen/CodeGen.hs | 13 +-
compiler/main/DriverPipeline.hs | 16 +-
compiler/main/DynFlags.hs | 53 ++-
compiler/main/GHC.hs | 20 +
compiler/main/HscMain.hs | 18 +-
compiler/main/HscStats.hs | 7 +-
compiler/main/HscTypes.lhs | 11 +-
compiler/main/InteractiveEval.hs | 17 +-
compiler/main/Packages.lhs | 75 +--
compiler/main/SysTools.lhs | 12 +-
compiler/main/TidyPgm.lhs | 26 +-
compiler/nativeGen/AsmCodeGen.lhs | 2 +-
compiler/nativeGen/PPC/CodeGen.hs | 13 +-
compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs | 56 +-
compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs | 14 +-
compiler/nativeGen/RegAlloc/Linear/Main.hs | 14 +-
compiler/nativeGen/SPARC/CodeGen.hs | 13 +-
compiler/nativeGen/TargetReg.hs | 70 +-
compiler/nativeGen/X86/CodeGen.hs | 83 ++-
compiler/parser/Lexer.x | 21 +-
compiler/parser/Parser.y.pp | 24 +-
compiler/parser/ParserCore.y | 10 +-
compiler/parser/RdrHsSyn.lhs | 105 +---
compiler/prelude/PrelNames.lhs | 18 +-
compiler/prelude/primops.txt.pp | 14 +
compiler/rename/RnBinds.lhs | 19 +-
compiler/rename/RnEnv.lhs | 209 +++++-
compiler/rename/RnExpr.lhs | 29 +-
compiler/rename/RnNames.lhs | 100 +---
compiler/rename/RnPat.lhs | 4 +-
compiler/rename/RnSource.lhs | 147 ++--
compiler/rename/RnTypes.lhs | 351 +++++++---
compiler/simplCore/CoreMonad.lhs | 7 +-
compiler/simplCore/FloatIn.lhs | 16 +-
compiler/simplCore/OccurAnal.lhs | 2 +-
compiler/simplCore/SimplCore.lhs | 12 +-
compiler/simplCore/SimplMonad.lhs | 3 +-
compiler/simplCore/SimplUtils.lhs | 132 ++--
compiler/simplCore/Simplify.lhs | 98 ++--
compiler/specialise/SpecConstr.lhs | 4 +-
compiler/specialise/Specialise.lhs | 8 +-
compiler/stgSyn/CoreToStg.lhs | 12 +
compiler/stranal/DmdAnal.lhs | 15 +-
compiler/stranal/WwLib.lhs | 25 +-
compiler/typecheck/FamInst.lhs | 35 +-
compiler/typecheck/Inst.lhs | 105 ++--
compiler/typecheck/TcBinds.lhs | 59 ++-
compiler/typecheck/TcCanonical.lhs | 258 ++++----
compiler/typecheck/TcDeriv.lhs | 2 +-
compiler/typecheck/TcEnv.lhs | 15 +-
compiler/typecheck/TcErrors.lhs | 59 +-
compiler/typecheck/TcEvidence.lhs | 99 ++-
compiler/typecheck/TcForeign.lhs | 17 +-
compiler/typecheck/TcGenGenerics.lhs | 25 +-
compiler/typecheck/TcHsSyn.lhs | 142 +++--
compiler/typecheck/TcHsType.lhs | 254 ++++----
compiler/typecheck/TcInstDcls.lhs | 125 +++-
compiler/typecheck/TcInteract.lhs | 458 +++++-------
compiler/typecheck/TcMType.lhs | 145 ++---
compiler/typecheck/TcMatches.lhs | 70 +--
compiler/typecheck/TcPat.lhs | 3 +-
compiler/typecheck/TcRnDriver.lhs | 116 +++-
compiler/typecheck/TcRnMonad.lhs | 3 +
compiler/typecheck/TcRnTypes.lhs | 173 +++---
compiler/typecheck/TcRules.lhs | 195 ++++--
compiler/typecheck/TcSMonad.lhs | 741 +++++++++++---------
compiler/typecheck/TcSimplify.lhs | 227 ++-----
compiler/typecheck/TcTyClsDecls.lhs | 236 ++++---
compiler/typecheck/TcTyDecls.lhs | 6 +-
compiler/typecheck/TcType.lhs | 15 +-
compiler/typecheck/TcUnify.lhs | 82 ++--
compiler/types/Coercion.lhs | 17 +-
compiler/types/FunDeps.lhs | 91 ++-
compiler/types/InstEnv.lhs | 43 +-
compiler/types/TyCon.lhs | 9 +-
compiler/types/Type.lhs | 28 +-
compiler/types/TypeRep.lhs | 37 +-
compiler/types/Unify.lhs | 50 +-
compiler/utils/Platform.hs | 12 +-
compiler/vectorise/Vectorise.hs | 6 +-
compiler/vectorise/Vectorise/Builtins/Base.hs | 2 +-
.../vectorise/Vectorise/Builtins/Initialise.hs | 2 +-
compiler/vectorise/Vectorise/Env.hs | 9 +-
compiler/vectorise/Vectorise/Exp.hs | 706 ++++++++++++++-----
config.guess | 482 ++++++-------
configure.ac | 31 +-
docs/users_guide/bugs.xml | 26 +-
docs/users_guide/flags.xml | 32 +-
docs/users_guide/packages.xml | 108 +++-
docs/users_guide/runghc.xml | 2 +-
docs/users_guide/using.xml | 21 +-
ghc.mk | 8 +-
ghc/InteractiveUI.hs | 72 ++-
ghc/hschooks.c | 5 +-
includes/Rts.h | 37 +-
includes/RtsAPI.h | 2 +-
includes/mkDerivedConstants.c | 3 +-
includes/rts/FileLock.h | 6 +-
includes/rts/Hooks.h | 6 +-
includes/rts/Messages.h | 15 +-
includes/rts/Threads.h | 4 +
includes/rts/Types.h | 6 +-
includes/stg/DLL.h | 25 +-
includes/stg/MiscClosures.h | 1 +
includes/stg/Types.h | 29 +-
libffi/ghc.mk | 3 +
.../Distribution/InstalledPackageInfo/Binary.hs | 4 +-
mk/config.mk.in | 12 +-
mk/validate-settings.mk | 18 +-
packages | 1 +
rts/Capability.c | 4 +-
rts/Disassembler.c | 18 +-
rts/{posix => }/FileLock.c | 11 +-
rts/{posix => }/FileLock.h | 0
rts/GetTime.h | 3 +
rts/Linker.c | 464 +++++++++++--
rts/PrimOps.cmm | 21 +-
rts/Printer.c | 24 +-
rts/ProfHeap.c | 2 +-
rts/RetainerProfile.c | 4 +-
rts/RtsDllMain.c | 4 +-
rts/RtsDllMain.h | 2 +-
rts/RtsFlags.c | 2 +-
rts/RtsStartup.c | 18 +-
rts/Stats.c | 21 +-
rts/Stats.h | 11 +-
rts/StgMiscClosures.cmm | 6 +-
rts/Task.c | 4 +-
rts/Ticky.c | 26 +-
rts/Trace.c | 26 +-
rts/eventlog/EventLog.c | 5 +-
rts/eventlog/EventLog.h | 2 +-
rts/ghc.mk | 21 +-
rts/hooks/MallocFail.c | 2 +-
rts/hooks/OutOfHeap.c | 2 +-
rts/hooks/StackOverflow.c | 2 +-
rts/package.conf.in | 4 +-
rts/posix/GetTime.c | 36 +-
rts/posix/OSMem.c | 2 +-
rts/sm/Evac.c | 2 +-
rts/sm/Sanity.c | 18 +-
rts/sm/Scav.c | 6 +-
rts/sm/Storage.c | 2 +-
rts/win32/GetTime.c | 74 ++-
rts/win32/IOManager.c | 2 +-
rts/win32/OSMem.c | 20 +-
rts/win32/ThrIOManager.c | 6 +-
rules/build-package-data.mk | 2 +-
rules/build-package-way.mk | 2 +-
rules/distdir-way-opts.mk | 12 +-
rules/package-config.mk | 8 +-
sync-all | 36 +
utils/ghc-cabal/Main.hs | 44 +-
utils/ghc-cabal/ghc.mk | 4 +-
utils/ghc-pkg/Main.hs | 32 +-
utils/ghc-pkg/ghc-pkg.wrapper | 2 +-
utils/ghc-pkg/ghc.mk | 7 +-
utils/ghctags/Main.hs | 12 +-
utils/runghc/runghc.hs | 10 +-
198 files changed, 5920 insertions(+), 4030 deletions(-)
diff --cc compiler/typecheck/TcGenGenerics.lhs
index f3e33c0,c4a2c33..0473ce5
--- a/compiler/typecheck/TcGenGenerics.lhs
+++ b/compiler/typecheck/TcGenGenerics.lhs
@@@ -396,112 -258,41 +396,111 @@@ tc_mkRepFamInsts :: GenericKind -
-> MetaTyCons -- Metadata datatypes to refer to
-> Module -- Used as the location of the new RepTy
-> TcM FamInst -- Generated representation0 coercion
-tc_mkRepTyCon tycon metaDts mod =
+tc_mkRepFamInsts gk tycon metaDts mod =
-- Consider the example input tycon `D`, where data D a b = D_ a
- do { -- `rep0` = GHC.Generics.Rep (type family)
- rep0 <- tcLookupTyCon repTyConName
+ do { -- `rep` = GHC.Generics.Rep or GHC.Generics.Rep1 (type family)
+ rep <- case gk of
+ Gen0 -> tcLookupTyCon repTyConName
+ Gen1 -> tcLookupTyCon rep1TyConName
+ ; let -- `tyvars` = [a,b]
- tyvars = tyConTyVars tycon
++ tyvars = (case gk of Gen0 -> id; Gen1 -> init) tyConTyVars tycon
+ tyvar_args = mkTyVarTys tyvars
+
+ -- `appT` = D a b
+ appT = [mkTyConApp tycon tyvar_args]
+
- -- `rep0Ty` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> *
- ; rep0Ty <- tc_mkRepTy tycon tyvar_args metaDts
+ -- `repTy` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> *
- ; repTy <- tc_mkRepTy gk tycon metaDts
++ ; repTy <- tc_mkRepTy gk tycon tyvar_args metaDts
-- `rep_name` is a name we generate for the synonym
- ; rep_name <- newGlobalBinder mod (mkGenR (nameOccName (tyConName tycon)))
- (nameSrcSpan (tyConName tycon))
+ ; rep_name <- let mkGen = case gk of Gen0 -> mkGenR; Gen1 -> mkGen1R
+ in newGlobalBinder mod (mkGen (nameOccName (tyConName tycon)))
+ (nameSrcSpan (tyConName tycon))
- ; let -- `tyvars` = [a,b]
- tyvars = (case gk of Gen0 -> id; Gen1 -> init) (tyConTyVars tycon)
-
- -- `appT` = D a b
- appT = [mkTyConApp tycon (mkTyVarTys tyvars)]
- ; return $ mkSynFamInst rep_name tyvars rep0 appT rep0Ty
+ ; return $ mkSynFamInst rep_name tyvars rep appT repTy
}
--
--
--------------------------------------------------------------------------------
-- Type representation
--------------------------------------------------------------------------------
-tc_mkRepTy :: -- The type to generate representation for, and instantiating types
- TyCon -> [Type]
+-- | See documentation of 'argTyFold'; that function uses the fields of this
+-- type to interpret the structure of a type when that type is considered as an
+-- argument to a constructor that is being represented with 'Rep1'.
+data ArgTyAlg a = ArgTyAlg
+ { ata_rec0 :: (Type -> a)
+ , ata_par1 :: a, ata_rec1 :: (Type -> a)
+ , ata_comp :: (Type -> a -> a)
+ }
+
+-- | @argTyFold@ implements a generalised and safer variant of the @arg@
+-- function from Figure 3 in <http://dreixel.net/research/pdf/gdmh.pdf>. @arg@
+-- is conceptually equivalent to:
+--
+-- > arg t = case t of
+-- > _ | isTyVar t -> if (t == argVar) then Par1 else Par0 t
+-- > App f [t'] |
+-- representable1 f &&
+-- t' == argVar -> Rec1 f
+-- > App f [t'] |
+-- representable1 f &&
+-- t' has tyvars -> f :.: (arg t')
+-- > _ -> Rec0 t
+--
+-- where @argVar@ is the last type variable in the data type declaration we are
+-- finding the representation for.
+--
+-- @argTyFold@ is more general than @arg@ because it uses 'ArgTyAlg' to
+-- abstract out the concrete invocations of @Par0@, @Rec0@, @Par1@, @Rec1@, and
+-- @:.:@.
+--
+-- @argTyFold@ is safer than @arg@ because @arg@ would lead to a GHC panic for
+-- some data types. The problematic case is when @t@ is an application of a
+-- non-representable type @f@ to @argVar@: @App f [argVar]@ is caught by the
+-- @_@ pattern, and ends up represented as @Rec0 t at . This type occurs /free/ in
+-- the RHS of the eventual @Rep1@ instance, which is therefore ill-formed. Some
+-- representable1 checks have been relaxed, and others were moved to
+-- @canDoGenerics1 at .
+argTyFold :: forall a. TyVar -> ArgTyAlg a -> Type -> a
+argTyFold argVar (ArgTyAlg {ata_rec0 = mkRec0,
+ ata_par1 = mkPar1, ata_rec1 = mkRec1,
+ ata_comp = mkComp}) =
+ -- mkRec0 is the default; use it if there is no interesting structure
+ -- (e.g. occurrences of parameters or recursive occurrences)
+ \t -> maybe (mkRec0 t) id $ go t where
+ go :: Type -> -- type to fold through
+ Maybe a -- the result (e.g. representation type), unless it's trivial
+ go t = isParam `mplus` isApp where
+
+ isParam = do -- handles parameters
+ t' <- getTyVar_maybe t
+ Just $ if t' == argVar then mkPar1 -- moreover, it is "the" parameter
+ else mkRec0 t -- NB mkRec0 instead of the conventional mkPar0
+
+ isApp = do -- handles applications
+ (phi, beta) <- tcSplitAppTy_maybe t
+
+ let interesting = argVar `elemVarSet` exactTyVarsOfType beta
+
+ -- Does it have no interesting structure to represent?
+ if not interesting then Nothing
+ else -- Is the argument the parameter? Special case for mkRec1.
+ if Just argVar == getTyVar_maybe beta then Just $ mkRec1 phi
+ else mkComp phi `fmap` go beta -- It must be a composition.
+
+
-
-
-
+tc_mkRepTy :: -- Gen0 or Gen1, for Rep or Rep1
+ GenericKind
+ -- The type to generate representation for
- -> TyCon
++ -> TyCon
++ -- ?
++ -> [Type]
-- Metadata datatypes to refer to
-> MetaTyCons
-- Generated representation0 type
-> TcM Type
- tc_mkRepTy gk tycon metaDts =
-tc_mkRepTy tycon ty_args metaDts =
++tc_mkRepTy gk tycon ty_args metaDts =
do
d1 <- tcLookupTyCon d1TyConName
c1 <- tcLookupTyCon c1TyConName
@@@ -519,13 -307,10 +518,13 @@@
let mkSum' a b = mkTyConApp plus [a,b]
mkProd a b = mkTyConApp times [a,b]
+ mkComp a b = mkTyConApp comp [a,b]
mkRec0 a = mkTyConApp rec0 [a]
+ mkRec1 a = mkTyConApp rec1 [a]
mkPar0 a = mkTyConApp par0 [a]
+ mkPar1 = mkTyConTy par1
mkD a = mkTyConApp d1 [metaDTyCon, sumP (tyConDataCons a)]
- mkC i d a = mkTyConApp c1 [d, prod i (dataConOrigArgTys a)
+ mkC i d a = mkTyConApp c1 [d, prod i (dataConInstOrigArgTys a ty_args)
(null (dataConFieldLabels a))]
-- This field has no label
mkS True _ a = mkTyConApp s1 [mkTyConTy nS1, a]
More information about the Cvs-ghc
mailing list