X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRename.lhs;h=409abef3c9f3e2407da158b2faa11791c2c29fcd;hb=30cf375e0bc79a6b71074a5e0fd2ec393241a751;hp=c5d18119d6e0a6301ff2409bcf1328aa995bf1fc;hpb=3990d44447b6c38a2effd68beb50da459dfd19fc;p=ghc-hetmet.git

diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs
index c5d1811..409abef 100644
--- a/ghc/compiler/rename/Rename.lhs
+++ b/ghc/compiler/rename/Rename.lhs
@@ -14,7 +14,7 @@ import Ubiq
 
 import HsSyn
 import RdrHsSyn		( RdrNameHsModule(..), RdrNameImportDecl(..) )
-import RnHsSyn		( RnName, RenamedHsModule(..), isRnTyConOrClass, isRnWired )
+import RnHsSyn		( RnName(..){-.. is for Ix hack only-}, RenamedHsModule(..), isRnTyConOrClass, isRnWired )
 
 --ToDo:rm: all for debugging only
 import Maybes
@@ -32,17 +32,18 @@ import ParseUtils	( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst(..),
 import RnMonad
 import RnNames		( getGlobalNames, GlobalNameInfo(..) )
 import RnSource		( rnSource )
-import RnIfaces		( findHiFiles, rnIfaces )
+import RnIfaces		( rnIfaces )
 import RnUtils		( RnEnv(..), extendGlobalRnEnv, emptyRnEnv, multipleOccWarn )
 
 import Bag		( isEmptyBag, unionBags, unionManyBags, bagToList, listToBag )
-import CmdLineOpts	( opt_HiDirList, opt_SysHiDirList )
+import CmdLineOpts	( opt_HiMap )
 import ErrUtils		( Error(..), Warning(..) )
 import FiniteMap	( emptyFM, eltsFM, fmToList, lookupFM{-ToDo:rm-} )
 import Maybes		( catMaybes )
 import Name		( isLocallyDefined, mkBuiltinName, Name, RdrName(..) )
 import PrelInfo		( builtinNameInfo, BuiltinNames(..), BuiltinKeys(..) )
 import PrelMods		( pRELUDE )
+import Unique		( ixClassKey )
 import UniqFM		( emptyUFM, lookupUFM, addListToUFM_C, eltsUFM )
 import UniqSupply	( splitUniqSupply )
 import Util		( panic, assertPanic )
@@ -65,7 +66,6 @@ renameModule :: UniqSupply
 \end{code} 
 
 ToDo: May want to arrange to return old interface for this module!
-ToDo: Builtin names which must be read.
 ToDo: Deal with instances (instance version, this module on instance list ???)
 
 \begin{code}
@@ -80,8 +80,9 @@ renameModule us input@(HsModule mod _ _ imports _ _ _ _ _ _ _ _ _ _)
     --				     , ppCat (map ppPStr (keysFM b_keys))
     --				     ]}) $
 
-    findHiFiles opt_HiDirList opt_SysHiDirList	    >>=	         \ hi_files ->
-    newVar (emptyFM, hi_files){-init iface cache-}  `thenPrimIO` \ iface_cache ->
+    makeHiMap opt_HiMap	    >>=	         \ hi_files ->
+--  pprTrace "HiMap:\n" (ppAboves [ ppCat [ppPStr m, ppStr p] | (m,p) <- fmToList hi_files])
+    newVar (emptyFM,emptyFM,hi_files){-init iface cache-}  `thenPrimIO` \ iface_cache ->
 
     fixIO ( \ ~(_, _, _, _, rec_occ_fm, rec_export_fn) ->
     let
@@ -163,15 +164,14 @@ renameModule us input@(HsModule mod _ _ imports _ _ _ _ _ _ _ _ _ _)
 
         pair_orig rn = (origName rn, rn)
 
-	-- we must ensure that the definitions of things in the BuiltinKey
-	-- table which may be *required* by the typechecker etc are read.
-
 	must_haves
-	  = [ name_fn (mkBuiltinName u pRELUDE str) 
-	    | (str, (u, name_fn)) <- fmToList b_keys,
+	  = [ name_fn (mkBuiltinName u mod str) 
+	    | ((str, mod), (u, name_fn)) <- fmToList b_keys,
 	      str `notElem` [ SLIT("main"), SLIT("mainPrimIO")] ]
     in
-    ASSERT (isEmptyBag orig_occ_dups)
+--  ASSERT (isEmptyBag orig_occ_dups)
+    (if (isEmptyBag orig_occ_dups) then \x->x
+     else pprTrace "orig_occ_dups:" (ppAboves [ ppCat [ppr PprDebug m, ppr PprDebug n, ppr PprDebug o] | (m,n,o) <- bagToList orig_occ_dups])) $
     ASSERT (isEmptyBag orig_def_dups)
 
     rnIfaces iface_cache imp_mods us3 orig_def_env orig_occ_env
@@ -195,8 +195,29 @@ renameModule us input@(HsModule mod _ _ imports _ _ _ _ _ _ _ _ _ _)
 \end{code}
 
 \begin{code}
+makeHiMap :: Maybe String -> IO (FiniteMap Module FilePath)
+
+makeHiMap Nothing = error "Rename.makeHiMap:no .hi map given by the GHC driver (?)"
+makeHiMap (Just f)
+  = readFile f	>>= \ cts ->
+    return (snag_mod emptyFM cts [])
+  where
+    -- we alternate between "snag"ging mod(ule names) and path(names),
+    -- accumulating names (reversed) and the final resulting map
+    -- as we move along.
+
+    snag_mod map  []       []   = map
+    snag_mod map  (' ':cs) rmod = snag_path map (_PK_ (reverse rmod)) cs []
+    snag_mod map  (c:cs)   rmod = snag_mod  map cs (c:rmod)
+
+    snag_path map mod []        rpath = addToFM map mod (reverse rpath)
+    snag_path map mod ('\n':cs) rpath = snag_mod (addToFM map mod (reverse rpath)) cs []
+    snag_path map mod (c:cs)    rpath = snag_path map mod cs (c:rpath)
+\end{code}
+
+\begin{code}
 {- TESTING:
-pprPIface (ParsedIface m v mv usgs lcm exm ims lfx ltdm lvdm lids ldp)
+pprPIface (ParsedIface m ms v mv usgs lcm exm ims lfx ltdm lvdm lids ldp)
   = ppAboves [
 	ppCat [ppPStr SLIT("interface"), ppPStr m, ppInt v,
 	       case mv of { Nothing -> ppNil; Just n -> ppInt n }],