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 <[email protected]> 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@. 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@. +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] _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
