Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/f4161297ed2a830c4bdcaa1b825ad12581a6caf9 >--------------------------------------------------------------- commit f4161297ed2a830c4bdcaa1b825ad12581a6caf9 Author: Ian Lynagh <i...@well-typed.com> Date: Fri Nov 2 13:41:02 2012 +0000 Don't use a unique in the stable name of a foreign export These names end up in the ABI, and hence part of the ABI hash. We don't want uniques in them so that we don't get spurious ABI hash changes. >--------------------------------------------------------------- compiler/deSugar/DsForeign.lhs | 19 +++++-------------- compiler/typecheck/TcEnv.lhs | 25 +++++++++++++++++++++++-- 2 files changed, 28 insertions(+), 16 deletions(-) diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs index 42aa740..59124e3 100644 --- a/compiler/deSugar/DsForeign.lhs +++ b/compiler/deSugar/DsForeign.lhs @@ -28,6 +28,7 @@ import Name import Type import TyCon import Coercion +import TcEnv import TcType import CmmExpr @@ -44,12 +45,10 @@ import FastString import DynFlags import Platform import Config -import Encoding import OrdList import Pair import Util -import Data.IORef import Data.Maybe import Data.List \end{code} @@ -213,20 +212,12 @@ dsFCall fn_id co fcall mDeclHeader = do (fcall', cDoc) <- case fcall of CCall (CCallSpec (StaticTarget cName mPackageId isFun) CApiConv safety) -> - do let wrapperRef = nextWrapperNum dflags - wrapperNum <- liftIO $ readIORef wrapperRef - liftIO $ writeIORef wrapperRef (wrapperNum + 1) - thisMod <- getModuleDs + do thisMod <- getModuleDs let pkg = packageIdString (modulePackageId thisMod) mod = moduleNameString (moduleName thisMod) - wrapperNameComponents = ["ghc_wrapper", - show wrapperNum, - pkg, mod, - unpackFS cName] - wrapperName = mkFastString - $ zEncodeString - $ intercalate ":" wrapperNameComponents - fcall' = CCall (CCallSpec (StaticTarget wrapperName mPackageId True) CApiConv safety) + wrapperNameComponents = [pkg, mod, unpackFS cName] + wrapperName <- mkWrapperName "ghc_wrapper" wrapperNameComponents + let fcall' = CCall (CCallSpec (StaticTarget wrapperName mPackageId True) CApiConv safety) c = includes $$ fun_proto <+> braces (cRet <> semi) includes = vcat [ text "#include <" <> ftext h <> text ">" diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index f3fc936..175ab9c 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -50,7 +50,8 @@ module TcEnv( -- New Ids newLocalName, newDFunName, newFamInstTyConName, newFamInstAxiomName, - mkStableIdFromString, mkStableIdFromName + mkStableIdFromString, mkStableIdFromName, + mkWrapperName ) where #include "HsVersions.h" @@ -80,10 +81,15 @@ import HscTypes import DynFlags import SrcLoc import BasicTypes +import Module import Outputable +import Encoding import FastString import ListSetOps import Util + +import Data.IORef +import Data.List \end{code} @@ -750,7 +756,10 @@ mkStableIdFromString :: String -> Type -> SrcSpan -> (OccName -> OccName) -> TcM mkStableIdFromString str sig_ty loc occ_wrapper = do uniq <- newUnique mod <- getModule - let occ = mkVarOcc (str ++ '_' : show uniq) :: OccName + name <- mkWrapperName "stable" [packageIdString (modulePackageId mod), + moduleNameString (moduleName mod), + str] + let occ = mkVarOccFS name :: OccName gnm = mkExternalName uniq mod (occ_wrapper occ) loc :: Name id = mkExportedLocalId gnm sig_ty :: Id return id @@ -759,6 +768,18 @@ mkStableIdFromName :: Name -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcI mkStableIdFromName nm = mkStableIdFromString (getOccString nm) \end{code} +\begin{code} +mkWrapperName :: (MonadIO m, HasDynFlags m) + => String -> [String] -> m FastString +mkWrapperName what components + = do dflags <- getDynFlags + let wrapperRef = nextWrapperNum dflags + wrapperNum <- liftIO $ readIORef wrapperRef + liftIO $ writeIORef wrapperRef (wrapperNum + 1) + let allComponents = what : show wrapperNum : components + return $ mkFastString $ zEncodeString $ intercalate ":" allComponents +\end{code} + %************************************************************************ %* * \subsection{Errors} _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
