Remove the large ghci banner, and the flags to choose which banner to show

[ghc-hetmet.git] / compiler / ghci / Linker.lhs

diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs
index afbd3b5..bce79c2 100644 (file)
--- a/compiler/ghci/Linker.lhs
+++ b/compiler/ghci/Linker.lhs
@@ -55,16 +55,15 @@ import DriverPhases
 import SrcLoc
 import UniqSet
 import Constants
+import FastString
 
 -- Standard libraries
 import Control.Monad
 
+import Data.Char
 import Data.IORef
 import Data.List
-import Foreign.Ptr
-import Foreign.C.Types
-import Foreign.C.String
-import Foreign.Storable
+import Foreign
 
 import System.IO
 import System.Directory
@@ -152,9 +151,10 @@ deleteFromLinkEnv to_remove
            new_pls = pls { closure_env = new_closure_env }
        writeIORef v_PersistentLinkerState new_pls
 
--- | Given a data constructor, find its internal name.
---   The info tables for data constructors have a field which records the source name
---   of the constructor as a CString. The format is:
+-- | Given a data constructor in the heap, find its Name.
+--   The info tables for data constructors have a field which records
+--   the source name of the constructor as a Ptr Word8 (UTF-8 encoded
+--   string). The format is:
 --
 --    Package:Module.Name
 --
@@ -166,11 +166,13 @@ dataConInfoPtrToName x = do
    theString <- ioToTcRn $ do
       let ptr = castPtr x :: Ptr StgInfoTable
       conDescAddress <- getConDescAddress ptr 
-      str <- peekCString conDescAddress  
-      return str
+      peekArray0 0 conDescAddress  
    let (pkg, mod, occ) = parse theString 
-       occName = mkOccName OccName.dataName occ
-       modName = mkModule (stringToPackageId pkg) (mkModuleName mod) 
+       pkgFS = mkFastStringByteList pkg
+       modFS = mkFastStringByteList mod
+       occFS = mkFastStringByteList occ
+       occName = mkOccNameFS OccName.dataName occFS
+       modName = mkModule (fsToPackageId pkgFS) (mkModuleNameFS modFS) 
    lookupOrig modName occName
 
    where
@@ -215,13 +217,13 @@ dataConInfoPtrToName x = do
          in the memory location: info_table_ptr + info_table_size
    -}
 
-   getConDescAddress :: Ptr StgInfoTable -> IO (Ptr CChar)
+   getConDescAddress :: Ptr StgInfoTable -> IO (Ptr Word8)
    getConDescAddress ptr = do
 #ifdef GHCI_TABLES_NEXT_TO_CODE
        offsetToString <- peek $ ptr `plusPtr` (- wORD_SIZE)
        return $ (ptr `plusPtr` stdInfoTableSizeB) `plusPtr` (fromIntegral (offsetToString :: StgWord))
 #else
-       peek $ intPtrToPtr $ (ptrToIntPtr ptr) + stdInfoTableSizeB
+       peek $ intPtrToPtr $ (ptrToIntPtr ptr) + fromIntegral stdInfoTableSizeB
 #endif
 
    -- parsing names is a little bit fiddly because we have a string in the form: 
@@ -231,20 +233,21 @@ dataConInfoPtrToName x = do
    -- this is not the conventional way of writing Haskell names. We stick with
    -- convention, even though it makes the parsing code more troublesome.
    -- Warning: this code assumes that the string is well formed.
-   parse :: String -> (String, String, String)
+   parse :: [Word8] -> ([Word8], [Word8], [Word8])
    parse input 
       = ASSERT (all (>0) (map length [pkg, mod, occ])) (pkg, mod, occ)
       where
-      (pkg, rest1) = break (==':') input 
+      dot = fromIntegral (ord '.')
+      (pkg, rest1) = break (== fromIntegral (ord ':')) input 
       (mod, occ) 
-         = (concat $ intersperse "." $ reverse modWords, occWord)
+         = (concat $ intersperse [dot] $ reverse modWords, occWord)
          where
          (modWords, occWord) = ASSERT (length rest1 > 0) (parseModOcc [] (tail rest1))
-      parseModOcc :: [String] -> String -> ([String], String)
+      parseModOcc :: [[Word8]] -> [Word8] -> ([[Word8]], [Word8])
       parseModOcc acc str
-         = case break (== '.') str of
+         = case break (== dot) str of
               (top, []) -> (acc, top)
-              (top, '.':bot) -> parseModOcc (top : acc) bot
+              (top, _:bot) -> parseModOcc (top : acc) bot
        
 
 getHValue :: HscEnv -> Name -> IO HValue
@@ -275,17 +278,31 @@ linkDependencies hsc_env span needed_mods = do
    linkModules dflags lnks
 
 
+-- | Temporarily extend the linker state.
+
 withExtendedLinkEnv :: [(Name,HValue)] -> IO a -> IO a
 withExtendedLinkEnv new_env action
     = bracket set_new_env
               reset_old_env
               (const action)
-    where set_new_env = do pls <- readIORef v_PersistentLinkerState
-                           let new_closure_env = extendClosureEnv (closure_env pls) new_env
-                               new_pls = pls { closure_env = new_closure_env }
-                           writeIORef v_PersistentLinkerState new_pls
-                           return (closure_env pls)
-          reset_old_env env = modifyIORef v_PersistentLinkerState (\pls -> pls{ closure_env = env })
+    where set_new_env = do 
+            pls <- readIORef v_PersistentLinkerState
+            let new_closure_env = extendClosureEnv (closure_env pls) new_env
+                new_pls = pls { closure_env = new_closure_env }
+            writeIORef v_PersistentLinkerState new_pls
+            return (closure_env pls)
+
+        -- Remember that the linker state might be side-effected
+        -- during the execution of the IO action, and we don't want to
+        -- lose those changes (we might have linked a new module or
+        -- package), so the reset action only removes the names we
+        -- added earlier.
+          reset_old_env env = do
+            modifyIORef v_PersistentLinkerState $ \pls ->
+                let cur = closure_env pls
+                    new = delListFromNameEnv cur (map fst new_env)
+                in
+                pls{ closure_env = new }
 
 -- filterNameMap removes from the environment all entries except 
 --     those for a given set of modules;