X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnMonad.lhs;h=189649b593862a967c3b8ce857711a164a0a068e;hb=f83ad713ad73e583fd138bb17e7341041b36a416;hp=feb0309864d3fbf357ee8ad592c6e9c5a56e24a4;hpb=18976e614fd90a8d81ced2c3e9cd8e38d72a1f40;p=ghc-hetmet.git

diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs
index feb0309..189649b 100644
--- a/ghc/compiler/rename/RnMonad.lhs
+++ b/ghc/compiler/rename/RnMonad.lhs
@@ -32,12 +32,18 @@ import SrcLoc		( noSrcLoc )
 import ErrUtils		( addShortErrLocLine, addShortWarnLocLine,
 			  pprBagOfErrors, ErrMsg, WarnMsg, Message
 			)
-import Name		( Module, Name, OccName, NamedThing(..), IfaceFlavour,
-			  isLocallyDefinedName, nameModule, nameOccName
+import Name		( Name, OccName, NamedThing(..),
+			  isLocallyDefinedName, nameModule, nameOccName,
+			  decode
+			)
+import Module		( Module, IfaceFlavour, setModuleFlavour, mkSysModuleFS,
+			  bootFlavour, moduleString, moduleIfaceFlavour, mkDynFlavour
 			)
 import NameSet		
 import RdrName		( RdrName )
-import CmdLineOpts	( opt_D_show_rn_trace, opt_IgnoreIfacePragmas, opt_WarnHiShadows )
+import CmdLineOpts	( opt_D_show_rn_trace, opt_IgnoreIfacePragmas, 
+			  opt_WarnHiShadows, opt_Static
+			)
 import PrelInfo		( builtinNames )
 import TysWiredIn	( boolTyCon )
 import SrcLoc		( SrcLoc, mkGeneratedSrcLoc )
@@ -54,6 +60,7 @@ import UniqSupply
 import Util
 import Outputable
 import DirUtils		( getDirectoryContents )
+import Directory	( doesFileExist )
 import IO		( hPutStrLn, stderr, isDoesNotExistError )
 import Monad		( foldM )
 import Maybe		( fromMaybe )
@@ -109,7 +116,9 @@ data RnDown s = RnDown {
 		  rn_ns   :: SSTRef s RnNameSupply,
 		  rn_errs :: SSTRef s (Bag WarnMsg, Bag ErrMsg),
 		  rn_occs :: SSTRef s ([Occurrence],[Occurrence]),	-- Occurrences: compulsory and optional resp
-		  rn_mod  :: Module
+		  rn_hi_map     :: ModuleHiMap,   -- for .hi files
+		  rn_hiboot_map :: ModuleHiMap,   -- for .hi-boot files
+		  rn_mod        :: Module
 		}
 
 type Occurrence = (Name, SrcLoc)		-- The srcloc is the occurrence site
@@ -120,8 +129,6 @@ data Necessity = Compulsory | Optional		-- We *must* find definitions for
 
 	-- For getting global names
 data GDown = GDown {
-		rn_hi_map     :: ModuleHiMap,   -- for .hi files
-		rn_hiboot_map :: ModuleHiMap,   -- for .hi-boot files
 		rn_ifaces     :: SSTRWRef Ifaces
 	     }
 
@@ -152,7 +159,7 @@ data RnMode	= SourceMode			-- Renaming source code
 type SearchPath = [(String,String)]	-- List of (directory,suffix) pairs to search 
                                         -- for interface files.
 
-type ModuleHiMap = FiniteMap String String
+type ModuleHiMap = FiniteMap String (String, Bool)
    -- mapping from module name to the file path of its corresponding
    -- interface file.
 \end{code}
@@ -273,7 +280,6 @@ type LocalVersion name   = (name, Version)
 
 data ParsedIface
   = ParsedIface
-      Module		 		-- Module name
       Version		 		-- Module version number
       [ImportVersion OccName]		-- Usages
       [ExportItem]			-- Exports
@@ -285,6 +291,12 @@ type InterfaceDetails = (VersionInfo Name,	-- Version information for what this
 			 ExportEnv, 		-- What this module exports
 			 [Module])		-- Instance modules
 
+
+-- needed by Main to fish out the fixities assoc list.
+getIfaceFixities :: InterfaceDetails -> Fixities
+getIfaceFixities (_, ExportEnv _ fs, _) = fs
+
+
 type RdrNamePragma = ()				-- Fudge for now
 -------------------
 
@@ -349,16 +361,17 @@ initRn :: Module -> UniqSupply -> SearchPath -> SrcLoc
        -> IO (r, Bag ErrMsg, Bag WarnMsg)
 
 initRn mod us dirs loc do_rn = do
+  (himap, hibmap) <- mkModuleHiMaps dirs
   names_var <- sstToIO (newMutVarSST (us, emptyFM, builtins))
   errs_var  <- sstToIO (newMutVarSST (emptyBag,emptyBag))
   iface_var <- sstToIO (newMutVarSST (emptyIfaces mod))
   occs_var  <- sstToIO (newMutVarSST initOccs)
-  (himap, hibmap) <- mkModuleHiMaps dirs
   let
         rn_down = RnDown { rn_loc = loc, rn_omit = \n -> False, rn_ns = names_var, 
 			   rn_errs = errs_var, rn_occs = occs_var,
+			   rn_hi_map = himap, rn_hiboot_map = hibmap,
 			   rn_mod = mod }
-	g_down  = GDown { rn_hi_map = himap, rn_hiboot_map = hibmap, rn_ifaces = iface_var }
+	g_down  = GDown {rn_ifaces = iface_var }
 
 	-- do the business
   res <- sstToIO (do_rn rn_down g_down)
@@ -387,11 +400,11 @@ emptyIfaces mod = Ifaces { iMod = mod,
 			   iDefData = emptyNameEnv, 
 			   iInstMods = []
 		  }
-
 builtins :: FiniteMap (Module,OccName) Name
-builtins = bagToFM $
-	   mapBag (\ name -> ((nameModule name, nameOccName name), name)) 
-		  builtinNames
+builtins = 
+   bagToFM (
+   mapBag (\ name ->  ((nameModule name, nameOccName name), name))
+ 	  builtinNames)
 
 	-- Initial value for the occurrence pool.
 initOccs :: ([Occurrence],[Occurrence])	-- Compulsory and optional respectively
@@ -402,24 +415,45 @@ initOccs = ([(getName boolTyCon, noSrcLoc)], [])
 	-- to do as much as possible explicitly.
 \end{code}
 
+We (allege) that it is quicker to build up a mapping from module names
+to the paths to their corresponding interface files once, than to search
+along the import part every time we slurp in a new module (which we 
+do quite a lot of.)
+
 \begin{code}
 mkModuleHiMaps :: SearchPath -> IO (ModuleHiMap, ModuleHiMap)
 mkModuleHiMaps dirs = foldM (getAllFilesMatching dirs) (env,env) dirs
  where
   env = emptyFM
 
+{- a pseudo file which signals that the interface files
+   contained in a particular directory have got their
+   corresponding object codes stashed away in a DLL
+   
+   This stuff is only needed to deal with Win32 DLLs,
+   and conceivably we conditionally compile in support
+   for handling it. (ToDo?)
+-}
+dir_contain_dll_his = "dLL_ifs.hi"
+
 getAllFilesMatching :: SearchPath
 		    -> (ModuleHiMap, ModuleHiMap)
 		    -> (FilePath, String) 
 		    -> IO (ModuleHiMap, ModuleHiMap)
 getAllFilesMatching dirs hims (dir_path, suffix) = ( do
     -- fpaths entries do not have dir_path prepended
-  fpaths <- getDirectoryContents dir_path
-  return (foldl addModules hims fpaths)
+  fpaths  <- getDirectoryContents dir_path
+  is_dyns <- catch
+		(if opt_Static || dir_path == "." then
+		     return False
+		 else
+		     doesFileExist (dir_path ++ '/': dir_contain_dll_his))
+		(\ _ {-don't care-} -> return False)
+  return (foldl (addModules is_dyns) hims fpaths)
    )  -- soft failure
       `catch` 
         (\ err -> do
-	      hPutStrLn stderr 
+	      hPutStrLn stderr
 		     ("Import path element `" ++ dir_path ++ 
 		      if (isDoesNotExistError err) then
 	                 "' does not exist, ignoring."
@@ -441,14 +475,14 @@ getAllFilesMatching dirs hims (dir_path, suffix) = ( do
       reverse (show interfaceFileFormatVersion) ++ '-':hi_boot_xiffus
    hi_boot_xiffus = "toob-ih." -- .hi-boot reversed.
 
-   addModules his@(hi_env, hib_env) nm = fromMaybe his $ 
-        FMAP (\ (mod_nm,v) -> (addToFM_C addNewOne hi_env mod_nm v, hib_env))
+   addModules is_dll his@(hi_env, hib_env) nm = fromMaybe his $ 
+        FMAP (\ (mod_nm,v) -> (addToFM_C addNewOne hi_env mod_nm (v, is_dll), hib_env))
 	    (go xiffus rev_nm)		       `seqMaybe`
 
-        FMAP (\ (mod_nm,v) -> (hi_env, addToFM_C overrideNew hib_env mod_nm v))
+        FMAP (\ (mod_nm,v) -> (hi_env, addToFM_C overrideNew hib_env mod_nm (v,is_dll)))
 	    (go hi_boot_version_xiffus rev_nm) `seqMaybe`
 
-	FMAP (\ (mod_nm,v) -> (hi_env, addToFM_C addNewOne hib_env mod_nm v))
+	FMAP (\ (mod_nm,v) -> (hi_env, addToFM_C addNewOne hib_env mod_nm (v,is_dll)))
 	    (go hi_boot_xiffus rev_nm)
     where
      rev_nm  = reverse nm
@@ -468,7 +502,7 @@ getAllFilesMatching dirs hims (dir_path, suffix) = ( do
 
    conflict old_path new_path
     | old_path /= new_path = 
-        pprTrace "Warning: " (text "Identically named interface files present on import path, " $$
+        pprTrace "Warning: " (text "Identically named interface files present on the import path, " $$
 			      text (show old_path) <+> text "shadows" $$
 			      text (show new_path) $$
 			      text "on the import path: " <+> 
@@ -537,6 +571,7 @@ thenRn   :: RnM s d a -> (a -> RnM s d b) -> RnM s d b
 thenRn_  :: RnM s d a -> RnM s d b -> RnM s d b
 andRn    :: (a -> a -> a) -> RnM s d a -> RnM s d a -> RnM s d a
 mapRn    :: (a -> RnM s d b) -> [a] -> RnM s d [b]
+mapRn_   :: (a -> RnM s d b) -> [a] -> RnM s d ()
 mapMaybeRn :: (a -> RnM s d (Maybe b)) -> [a] -> RnM s d [b]
 sequenceRn :: [RnM s d a] -> RnM s d [a]
 foldlRn :: (b  -> a -> RnM s d b) -> b -> [a] -> RnM s d b
@@ -563,6 +598,11 @@ mapRn f (x:xs)
     mapRn f xs 	`thenRn` \ rs ->
     returnRn (r:rs)
 
+mapRn_ f []     = returnRn ()
+mapRn_ f (x:xs) = 
+    f x		`thenRn_`
+    mapRn_ f xs
+
 foldlRn k z [] = returnRn z
 foldlRn k z (x:xs) = k z x	`thenRn` \ z' ->
 		     foldlRn k z' xs
@@ -671,6 +711,15 @@ newInstUniq key (RnDown {rn_ns = names_var}) l_down
     in
     writeMutVarSST names_var (us, mapInst', cache)	`thenSST_`
     returnSST uniq
+
+getUniqRn :: RnM s d Unique
+getUniqRn (RnDown {rn_ns = names_var}) l_down
+ = readMutVarSST names_var `thenSST` \ (us, mapInst, cache) ->
+   let
+     (us1,us') = splitUniqSupply us
+   in
+   writeMutVarSST names_var (us', mapInst, cache)  `thenSST_`
+   returnSST (uniqFromSupply us1)
 \end{code}
 
 ================  Occurrences =====================
@@ -857,10 +906,37 @@ setIfacesRn :: Ifaces -> RnMG ()
 setIfacesRn ifaces rn_down (GDown {rn_ifaces = iface_var})
   = writeMutVarSST iface_var ifaces
 
-getModuleHiMap :: Bool -> RnMG ModuleHiMap
-getModuleHiMap want_hi_boot rn_down (GDown {rn_hi_map = himap, rn_hiboot_map = hibmap})
+getModuleHiMap :: Bool -> RnM s d ModuleHiMap
+getModuleHiMap want_hi_boot (RnDown {rn_hi_map = himap, rn_hiboot_map = hibmap}) _ 
   | want_hi_boot = returnSST hibmap
   | otherwise    = returnSST himap
+\end{code}
+
+The interface file format is capable of distinguishing
+between normal imports/exports of names from other modules
+and 'hi-boot' mentions of names, with the flavour in the
+being encoded inside a @Module@.
+
+@setModuleFlavourRn@ fixes up @Module@ values containing
+normal flavours, returning a @Module@ value containing
+the attributes of the module that's in scope. The only
+attribute at the moment is the DLLness of a module, i.e.,
+whether the object code for that module resides in a
+Win32 DLL or not.
+
+\begin{code}
+setModuleFlavourRn :: Module -> RnM s d Module
+setModuleFlavourRn mod
+  | bootFlavour hif = returnRn mod
+  | otherwise       =
+     getModuleHiMap (bootFlavour hif) `thenRn` \ himap ->
+     case (lookupFM himap mod_pstr) of
+       Nothing -> returnRn mod
+       Just (_, is_in_a_dll) ->
+           returnRn (setModuleFlavour (mkDynFlavour is_in_a_dll hif) mod)
+    where
+      mod_pstr = moduleString mod
+      hif      = moduleIfaceFlavour mod
 
 \end{code}