Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : ghc-7.2
http://hackage.haskell.org/trac/ghc/changeset/f1877b924c760200a6b51f637606354f98b5550e >--------------------------------------------------------------- commit f1877b924c760200a6b51f637606354f98b5550e Author: Simon Marlow <marlo...@gmail.com> Date: Fri Jul 8 10:47:19 2011 +0100 Change the code generated for deriving Typeable, to match the changes to the Typeable library. We now generate an MD5 hash of the fully-qualified TyCon name at compile time. >--------------------------------------------------------------- compiler/prelude/PrelNames.lhs | 11 +++++---- compiler/typecheck/TcGenDeriv.lhs | 41 ++++++++++++++++++++++++++++++++---- 2 files changed, 42 insertions(+), 10 deletions(-) diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index 95bc2d6..af4b600 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -282,7 +282,7 @@ gHC_PRIM, gHC_TYPES, gHC_UNIT, gHC_ORDERING, gHC_GENERICS, gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING, dATA_FOLDABLE, dATA_TRAVERSABLE, 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, gENERICS, + gHC_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC, tYPEABLE, tYPEABLE_INTERNAL, gENERICS, dOTNET, rEAD_PREC, lEX, gHC_INT, gHC_WORD, mONAD, mONAD_FIX, mONAD_GROUP, mONAD_ZIP, aRROW, cONTROL_APPLICATIVE, gHC_DESUGAR, rANDOM, gHC_EXTS, cONTROL_EXCEPTION_BASE :: Module @@ -323,7 +323,8 @@ gHC_FLOAT = mkBaseModule (fsLit "GHC.Float") gHC_TOP_HANDLER = mkBaseModule (fsLit "GHC.TopHandler") sYSTEM_IO = mkBaseModule (fsLit "System.IO") dYNAMIC = mkBaseModule (fsLit "Data.Dynamic") -tYPEABLE = mkBaseModule (fsLit "Data.Typeable") +tYPEABLE = mkBaseModule (fsLit "Data.Typeable") +tYPEABLE_INTERNAL = mkBaseModule (fsLit "Data.Typeable.Internal") gENERICS = mkBaseModule (fsLit "Data.Data") dOTNET = mkBaseModule (fsLit "GHC.Dotnet") rEAD_PREC = mkBaseModule (fsLit "Text.ParserCombinators.ReadPrec") @@ -546,10 +547,10 @@ 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, mkTypeRep_RDR, mkTyConRep_RDR :: RdrName +typeOf_RDR, mkTyCon_RDR, mkTyConApp_RDR :: RdrName typeOf_RDR = varQual_RDR tYPEABLE (fsLit "typeOf") -mkTypeRep_RDR = varQual_RDR tYPEABLE (fsLit "mkTyConApp") -mkTyConRep_RDR = varQual_RDR tYPEABLE (fsLit "mkTyCon") +mkTyCon_RDR = varQual_RDR tYPEABLE_INTERNAL (fsLit "mkTyCon") +mkTyConApp_RDR = varQual_RDR tYPEABLE (fsLit "mkTyConApp") undefined_RDR :: RdrName undefined_RDR = varQual_RDR gHC_ERR (fsLit "undefined") diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index e412910..1f47180 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -52,13 +52,19 @@ import TysWiredIn import Type import TypeRep import VarSet +import Module import State import Util import MonadUtils import Outputable import FastString import Bag -import Data.List ( partition, intersperse ) +import Binary hiding (get,put) +import Fingerprint +import Constants + +import System.IO.Unsafe ( unsafePerformIO ) +import Data.List ( partition, intersperse ) \end{code} \begin{code} @@ -1161,8 +1167,9 @@ From the data type we generate - instance Typeable2 T where - typeOf2 _ = mkTyConApp (mkTyConRep "T") [] + instance Typeable2 T where + typeOf2 _ = mkTyConApp (mkTyCon <hash-high> <hash-low> + <pkg> <module> "T") [] We are passed the Typeable2 class as well as T @@ -1173,9 +1180,33 @@ gen_Typeable_binds loc tycon mk_easy_FunBind loc (mk_typeOf_RDR tycon) -- Name of appropriate type0f function [nlWildPat] - (nlHsApps mkTypeRep_RDR [tycon_rep, nlList []]) + (nlHsApps mkTyConApp_RDR [tycon_rep, nlList []]) where - tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon))) + tycon_name = tyConName tycon + modl = nameModule tycon_name + pkg = modulePackageId modl + + modl_fs = moduleNameFS (moduleName modl) + pkg_fs = packageIdFS pkg + name_fs = occNameFS (nameOccName tycon_name) + + tycon_rep = nlHsApps mkTyCon_RDR + (map nlHsLit [int64 high, + int64 low, + HsString pkg_fs, + HsString modl_fs, + HsString name_fs]) + + Fingerprint high low = unsafePerformIO $ -- ugh + computeFingerprint (error "gen_typeable_binds") + (unpackFS pkg_fs ++ + unpackFS modl_fs ++ + unpackFS name_fs) + + int64 + | wORD_SIZE == 4 = HsWord64Prim . fromIntegral + | otherwise = HsWordPrim . fromIntegral + mk_typeOf_RDR :: TyCon -> RdrName -- Use the arity of the TyCon to make the right typeOfn function _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
