From: simonpj Date: Fri, 19 Oct 2001 11:47:18 +0000 (+0000) Subject: [project @ 2001-10-19 11:47:18 by simonpj] X-Git-Tag: Approximately_9120_patches~772 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=c85373c7dd8034f427c010490f15590deb589490;hp=c10cab3677090a2bf9d6bf1f091121f43b6899ad;p=ghc-hetmet.git [project @ 2001-10-19 11:47:18 by simonpj] Fix codegen globalisation for -split-objs --- diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index 303e0c7..2cd0ef0 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -300,8 +300,8 @@ pprLocal sty uniq occ -- Like Local, except that we only omit the unique in Iface style pprSysLocal sty uniq occ | codeStyle sty = pprUnique uniq - | ifaceStyle sty = pprOccName occ -- The tidy phase has ensured that OccNames - -- are enough + | ifaceStyle sty = pprOccName occ -- The tidy phase has ensured + -- that OccNames are enough | otherwise = pprOccName occ <> char '_' <> pprUnique uniq -- If the tidy phase hasn't run, the OccName -- is unlikely to be informative (like 's'), diff --git a/ghc/compiler/basicTypes/OccName.lhs b/ghc/compiler/basicTypes/OccName.lhs index c2d4533..e9584e1 100644 --- a/ghc/compiler/basicTypes/OccName.lhs +++ b/ghc/compiler/basicTypes/OccName.lhs @@ -18,7 +18,7 @@ module OccName ( mkSuperDictSelOcc, mkDFunOcc, mkForeignExportOcc, mkDictOcc, mkIPOcc, mkWorkerOcc, mkMethodOcc, mkDefaultMethodOcc, mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkSpecOcc, - mkGenOcc1, mkGenOcc2, + mkGenOcc1, mkGenOcc2, mkLocalOcc, isTvOcc, isTcOcc, isDataOcc, isDataSymOcc, isSymOcc, isValOcc, @@ -42,6 +42,7 @@ module OccName ( import Char ( isDigit, isUpper, isLower, ISALPHANUM, ord, chr, digitToInt ) import Util ( thenCmp ) +import Unique ( Unique ) import FiniteMap ( FiniteMap, emptyFM, lookupFM, addToFM, elemFM ) import Outputable import GlaExts @@ -280,7 +281,7 @@ NB: The string must already be encoded! mk_deriv :: NameSpace -> String -- Distinguishes one sort of derived name from another -> EncodedString -- Must be already encoded!! We don't want to encode it a - -- second time because encoding isn't itempotent + -- second time because encoding isn't idempotent -> OccName mk_deriv occ_sp sys_prefix str = mkSysOcc occ_sp (encode sys_prefix ++ str) @@ -292,15 +293,15 @@ mkDictOcc, mkIPOcc, mkWorkerOcc, mkDefaultMethodOcc, :: OccName -> OccName -- These derived variables have a prefix that no Haskell value could have -mkWorkerOcc = mk_simple_deriv varName "$w" -mkDefaultMethodOcc = mk_simple_deriv varName "$dm" -mkDerivedTyConOcc = mk_simple_deriv tcName ":" -- The : prefix makes sure it classifies -mkClassTyConOcc = mk_simple_deriv tcName ":T" -- as a tycon/datacon -mkClassDataConOcc = mk_simple_deriv dataName ":D" -- -mkDictOcc = mk_simple_deriv varName "$d" -mkIPOcc = mk_simple_deriv varName "$i" -mkSpecOcc = mk_simple_deriv varName "$s" -mkForeignExportOcc = mk_simple_deriv varName "$f" +mkWorkerOcc = mk_simple_deriv varName "$w" +mkDefaultMethodOcc = mk_simple_deriv varName "$dm" +mkDerivedTyConOcc = mk_simple_deriv tcName ":" -- The : prefix makes sure it classifies +mkClassTyConOcc = mk_simple_deriv tcName ":T" -- as a tycon/datacon +mkClassDataConOcc = mk_simple_deriv dataName ":D" -- +mkDictOcc = mk_simple_deriv varName "$d" +mkIPOcc = mk_simple_deriv varName "$i" +mkSpecOcc = mk_simple_deriv varName "$s" +mkForeignExportOcc = mk_simple_deriv varName "$f" mkGenOcc1 = mk_simple_deriv varName "$gfrom" -- Generics mkGenOcc2 = mk_simple_deriv varName "$gto" -- Generics mk_simple_deriv sp px occ = mk_deriv sp px (occNameString occ) @@ -309,9 +310,15 @@ mk_simple_deriv sp px occ = mk_deriv sp px (occNameString occ) \begin{code} mkSuperDictSelOcc :: Int -- Index of superclass, eg 3 -> OccName -- Class, eg "Ord" - -> OccName -- eg "p3Ord" + -> OccName -- eg "$p3Ord" mkSuperDictSelOcc index cls_occ = mk_deriv varName "$p" (show index ++ occNameString cls_occ) + +mkLocalOcc :: Unique -- Unique + -> OccName -- Local name (e.g. "sat") + -> OccName -- Nice unique version ("$L23sat") +mkLocalOcc uniq occ + = mk_deriv varName "$L" (show uniq ++ occNameString occ) \end{code} diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs index 94eb0b3..7db7948 100644 --- a/ghc/compiler/codeGen/CodeGen.lhs +++ b/ghc/compiler/codeGen/CodeGen.lhs @@ -40,7 +40,8 @@ import CmdLineOpts ( DynFlags, DynFlag(..), opt_SccProfilingOn, opt_EnsureSplittableC ) import CostCentre ( CostCentre, CostCentreStack ) import Id ( Id, idName, setIdName ) -import Name ( globaliseName ) +import Name ( nameSrcLoc, nameOccName, nameUnique, isLocalName, mkGlobalName ) +import OccName ( mkLocalOcc ) import Module ( Module ) import PrimRep ( PrimRep(..) ) import TyCon ( TyCon, isDataTyCon ) @@ -194,7 +195,8 @@ cgTopBinding (StgNonRec srt_info id rhs, srt) mkSRT srt_label srt [] `thenC` setSRTLabel srt_label ( cgTopRhs id' rhs srt_info `thenFC` \ (id, info) -> - addBindC id info + addBindC id info -- Add the un-globalised Id to the envt, so we + -- find it when we look up occurrences ) cgTopBinding (StgRec srt_info pairs, srt) @@ -228,31 +230,16 @@ mkSRT lbl ids these `thenFC` \ (id, _, _) -> returnFC id (id':_) -> returnFC id' --- If we're splitting the object, we need to globalise all the top-level names --- (and then make sure we only use the globalised one in any C label we use --- which refers to this name). -maybeGlobaliseId :: Id -> FCode Id -maybeGlobaliseId id - | opt_EnsureSplittableC - = moduleName `thenFC` \ mod -> - returnFC (setIdName id (globaliseName (idName id) mod)) - | otherwise -- Globalise the name for -split-objs - = returnFC id - -maybeSplitCode - | opt_EnsureSplittableC = CSplitMarker - | otherwise = AbsCNop - -- Urgh! I tried moving the forkStatics call from the rhss of cgTopRhs -- to enclose the listFCs in cgTopBinding, but that tickled the -- statics "error" call in initC. I DON'T UNDERSTAND WHY! cgTopRhs :: Id -> StgRhs -> SRT -> FCode (Id, CgIdInfo) - -- the Id is passed along for setting up a binding... + -- The Id is passed along for setting up a binding... + -- It's already been globalised if necessary cgTopRhs bndr (StgRhsCon cc con args) srt - = maybeGlobaliseId bndr `thenFC` \ bndr' -> - forkStatics (cgTopRhsCon bndr con args) + = forkStatics (cgTopRhsCon bndr con args) cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag args body) srt = -- There should be no free variables @@ -260,6 +247,39 @@ cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag args body) srt let lf_info = mkClosureLFInfo bndr TopLevel [{-no fvs-}] upd_flag args in - maybeGlobaliseId bndr `thenFC` \ bndr' -> - forkStatics (cgTopRhsClosure bndr' cc bi srt args body lf_info) + forkStatics (cgTopRhsClosure bndr cc bi srt args body lf_info) \end{code} + + +%************************************************************************ +%* * +\subsection{Stuff to support splitting} +%* * +%************************************************************************ + +If we're splitting the object, we need to globalise all the top-level names +(and then make sure we only use the globalised one in any C label we use +which refers to this name). + +\begin{code} +maybeGlobaliseId :: Id -> FCode Id +maybeGlobaliseId id + | opt_EnsureSplittableC, -- Globalise the name for -split-objs + isLocalName name + = moduleName `thenFC` \ mod -> + returnFC (setIdName id (mkGlobalName uniq mod new_occ (nameSrcLoc name))) + | otherwise + = returnFC id + where + name = idName id + uniq = nameUnique name + new_occ = mkLocalOcc uniq (nameOccName name) + -- We want to conjure up a name that can't clash with any + -- existing name. So we generate + -- Mod_$L243foo + -- where 243 is the unique. + +maybeSplitCode + | opt_EnsureSplittableC = CSplitMarker + | otherwise = AbsCNop +\end{code} \ No newline at end of file diff --git a/ghc/compiler/coreSyn/CoreTidy.lhs b/ghc/compiler/coreSyn/CoreTidy.lhs index bc3dd71..77f989b 100644 --- a/ghc/compiler/coreSyn/CoreTidy.lhs +++ b/ghc/compiler/coreSyn/CoreTidy.lhs @@ -28,8 +28,8 @@ import Id ( idType, idInfo, idName, isExportedId, import IdInfo {- loads of stuff -} import NewDemand ( isBottomingSig, topSig ) import BasicTypes ( isNeverActive ) -import Name ( getOccName, nameOccName, globaliseName, setNameOcc, - localiseName, isGlobalName, setNameUnique +import Name ( getOccName, nameOccName, mkLocalName, mkGlobalName, + localiseName, isGlobalName, nameSrcLoc ) import NameEnv ( filterNameEnv ) import OccName ( TidyOccEnv, initTidyOccEnv, tidyOccName ) @@ -503,7 +503,7 @@ tidyTopName mod ns occ_env external name -- so they already have the "right" unique -- And it's a system-wide unique too - | local && internal = (ns { nsUniqs = us2 }, occ_env', unique_name) + | local && internal = (ns_w_local, occ_env', new_local_name) -- Even local, internal names must get a unique occurrence, because -- if we do -split-objs we globalise the name later, in the code generator -- @@ -511,11 +511,11 @@ tidyTopName mod ns occ_env external name -- the byte-code generator builds a system-wide Name->BCO symbol table | local && external = case lookupFM ns_names key of - Just orig -> (ns, occ_env', orig) - Nothing -> (ns { nsUniqs = us2, nsNames = ns_names' }, occ_env', global_name) + Just orig -> (ns, occ_env', orig) + Nothing -> (ns_w_global, occ_env', new_global_name) -- If we want to globalise a currently-local name, check -- whether we have already assigned a unique for it. - -- If so, use it; if not, extend the table. + -- If so, use it; if not, extend the table (ns_w_global). -- This is needed when *re*-compiling a module in GHCi; we want to -- use the same name for externally-visible things as we did before. @@ -529,9 +529,14 @@ tidyTopName mod ns occ_env external name ns_names = nsNames ns ns_uniqs = nsUniqs ns (us1, us2) = splitUniqSupply ns_uniqs - unique_name = setNameUnique (setNameOcc name occ') (uniqFromSupply us1) - global_name = globaliseName unique_name mod - ns_names' = addToFM ns_names key global_name + uniq = uniqFromSupply us1 + loc = nameSrcLoc name + + new_local_name = mkLocalName uniq occ' loc + new_global_name = mkGlobalName uniq mod occ' loc + + ns_w_local = ns { nsUniqs = us2 } + ns_w_global = ns { nsUniqs = us2, nsNames = addToFM ns_names key new_global_name } ------------ Worker --------------