[project @ 2000-11-16 16:54:36 by simonmar]

WOOHOO!  GHCi interprets "Hello World":

 _____  __   __  ____         _________________________________________________
(|      ||   || (|  |)        GHC Interactive, version 5.00
||  __  ||___|| ||     ()     For Haskell 98.
||   |) ||---|| ||     ||     http://www.haskell.org/ghc
||   || ||   || ||     (|     Bug reports to: glasgow-haskell-bugs@haskell.org
(|___|| ||   || (|__|) \\______________________________________________________

Loading package std ... resolving ... done.
Prelude> :l Main
cmLoadModule: downsweep begins
getSummary: Main
after tsort:

NONREC
   ModSummary { ms_mod = Main, ms_imps = [] ms_srcimps = [] }
CHECKING OLD IFACE for hs = Just "./Main.hs", hspp = Just "/tmp/ghc25011.hspp"
COMPILATION IS REQUIRED
UPSWEEP COMPLETELY SUCCESSFUL
CmLink.link: linkables are ...
LinkableM Main [Trees [Main.main = letP stg_cIM = (@PP Native PrelShow.$fShow[] Native PrelShow.$fShowChar)
                                   in
                                   letP stg_cIL = (@IP Native PrelBase.unpackCString# 141613256#)
                                   in
                                   (@PP (@PP Native PrelIO.print stg_cIM) stg_cIL)]]
Main.main
CmLink.link: done
Prelude> Main.main
Run expression: Main.main
evalI:
141613256#

"Hello, world!"
done.

diff --git a/ghc/compiler/compMan/CmLink.lhs b/ghc/compiler/compMan/CmLink.lhs
index 9adf362..28b7a47 100644 (file)
--- a/ghc/compiler/compMan/CmLink.lhs
+++ b/ghc/compiler/compMan/CmLink.lhs
@@ -11,7 +11,8 @@ module CmLink ( Linkable(..),  Unlinked(..),
                LinkResult(..),
                 link, 
                unload,
-                PersistentLinkerState{-abstractly!-}, emptyPLS
+                PersistentLinkerState{-abstractly!-}, emptyPLS,
+               lookupClosure
   ) where
 
 
@@ -19,15 +20,16 @@ import Interpreter
 import DriverPipeline
 import CmTypes
 import CmStaticInfo    ( GhciMode(..) )
-import Module          ( ModuleName, PackageName )
 import Outputable      ( SDoc )
-import FiniteMap
 import Digraph         ( SCC(..), flattenSCC )
-import Outputable
-import Exception
 import DriverUtil
+import Module          ( ModuleName, PackageName )
+import RdrName
+import FiniteMap
+import Outputable
 import Panic           ( panic )
 
+import Exception
 import IO
 
 #include "HsVersions.h"
@@ -102,14 +104,18 @@ link :: GhciMode          -- interactive or batch
 --        to be actually linked this time around (or unlinked and re-linked 
 --        if the module was recompiled).
 
-link Batch batch_attempt_linking linkables pls1
-   | batch_attempt_linking
-   = do hPutStrLn stderr "CmLink.link(batch): linkables are ..."
+link mode batch_attempt_linking linkables pls1
+   = do hPutStrLn stderr "CmLink.link: linkables are ..."
         hPutStrLn stderr (showSDoc (vcat (map ppr linkables)))
-        let o_files = concatMap getOfiles linkables
+       res <- link' mode batch_attempt_linking linkables pls1
+       hPutStrLn stderr "CmLink.link: done"
+       return res
+
+link' Batch batch_attempt_linking linkables pls1
+   | batch_attempt_linking
+   = do let o_files = concatMap getOfiles linkables
         doLink o_files
        -- doLink only returns if it succeeds
-        hPutStrLn stderr "CmLink.link(batch): done"
         return (LinkOK pls1)
    | otherwise
    = do hPutStrLn stderr "CmLink.link(batch): upsweep (partially?) failed OR main not exported;"
@@ -119,8 +125,9 @@ link Batch batch_attempt_linking linkables pls1
       getOfiles (LP _)    = panic "CmLink.link(getOfiles): shouldn't get package linkables"
       getOfiles (LM _ us) = map nameOfObject (filter isObject us)
 
-link Interactive batch_attempt_linking linkables pls1
-   = linkObjs linkables pls1
+link' Interactive batch_attempt_linking linkables pls1
+    = linkObjs linkables pls1
+        
 
 ppLinkableSCC :: SCC Linkable -> SDoc
 ppLinkableSCC = ppr . flattenSCC
@@ -179,6 +186,7 @@ invalidLinkable = throwDyn (OtherError "linkable doesn't contain entirely object
 -- link all the interpreted code in one go.  We first remove from the
 -- various environments any previous versions of these modules.
 linkFinish pls mods ul_trees = do
+   resolveObjs
    let itbl_env'    = filterRdrNameEnv mods (itbl_env pls)
        closure_env' = filterRdrNameEnv mods (closure_env pls)
        stuff        = [ (trees,itbls) | Trees trees itbls <- ul_trees ]
@@ -190,12 +198,17 @@ linkFinish pls mods ul_trees = do
                                  closure_env = new_closure_env,
                                  itbl_env    = new_itbl_env
                        }
-   resolveObjs
+   putStrLn (showSDoc (vcat (map ppr (keysFM new_closure_env))))
    return (LinkOK new_pls)
 
 -- purge the current "linked image"
 unload :: PersistentLinkerState -> IO PersistentLinkerState
 unload pls = return pls{ closure_env = emptyFM, itbl_env = emptyFM }
 
+lookupClosure :: RdrName -> PersistentLinkerState -> Maybe HValue
+lookupClosure nm PersistentLinkerState{ closure_env = cenv } =
+   case lookupFM cenv nm of
+       Nothing -> Nothing
+       Just hv -> Just hv
 #endif
 \end{code}

diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs
index e59a462..69597c6 100644 (file)
--- a/ghc/compiler/compMan/CompManager.lhs
+++ b/ghc/compiler/compMan/CompManager.lhs
@@ -6,7 +6,8 @@
 \begin{code}
 module CompManager ( cmInit, cmLoadModule, 
                      cmGetExpr, cmRunExpr,
-                     CmState, emptyCmState  -- abstract
+                     CmState, emptyCmState,  -- abstract
+                    cmLookupSymbol --tmp
                    )
 where
 
@@ -19,10 +20,7 @@ import Outputable
 import UniqFM          ( emptyUFM, lookupUFM, addToUFM, delListFromUFM )
 import Digraph         ( SCC(..), stronglyConnComp, flattenSCC, flattenSCCs )
 
-import CmLink          ( PersistentLinkerState, emptyPLS, Linkable(..), 
-                         link, LinkResult(..), 
-                         filterModuleLinkables, modname_of_linkable,
-                         is_package_linkable, findModuleLinkable )
+import CmLink
 import CmTypes
 import HscTypes
 import Interpreter     ( HValue )
@@ -35,6 +33,7 @@ import GetImports
 import HscTypes                ( HomeSymbolTable, HomeIfaceTable, 
                          PersistentCompilerState, ModDetails(..) )
 import Name            ( lookupNameEnv )
+import RdrName
 import Module
 import PrelNames       ( mainName )
 import HscMain         ( initPersistentCompilerState )
@@ -511,4 +510,7 @@ summarise mod location
                return (Just time)) 
            `catch`
            (\err -> return Nothing)
+
+cmLookupSymbol :: RdrName -> CmState -> Maybe HValue
+cmLookupSymbol nm CmState{ pls = pls } = lookupClosure nm pls
 \end{code}

diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs
index f4193fc..2aa1c67 100644 (file)
--- a/ghc/compiler/ghci/InteractiveUI.hs
+++ b/ghc/compiler/ghci/InteractiveUI.hs
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------------
--- $Id: InteractiveUI.hs,v 1.2 2000/11/16 11:39:37 simonmar Exp $
+-- $Id: InteractiveUI.hs,v 1.3 2000/11/16 16:54:36 simonmar Exp $
 --
 -- GHC Interactive User Interface
 --
@@ -9,12 +9,16 @@
 
 module InteractiveUI (interactiveUI) where
 
+#include "HsVersions.h"
+
 import CompManager
 import CmStaticInfo
 import DriverUtil
 import DriverState
 import Linker
 import Module
+import RdrName                         -- tmp
+import OccName                         -- tmp
 import Panic
 import Util
 
@@ -27,6 +31,8 @@ import Directory
 import IO
 import Char
 
+import PrelGHC  ( unsafeCoerce# )
+
 -----------------------------------------------------------------------------
 
 ghciWelcomeMsg = "\ 
@@ -87,7 +93,7 @@ uiLoop :: GHCi ()
 uiLoop = do
   st <- getGHCiState
 #ifndef NO_READLINE
-  l <- io (readline (moduleNameUserString (current_module st)  ++ ">"))
+  l <- io (readline (moduleNameUserString (current_module st)  ++ "> "))
 #else
   l <- io (hGetLine stdin)
 #endif
@@ -101,12 +107,25 @@ uiLoop = do
          runCommand l
          uiLoop  
 
-runCommand c = myCatch (doCommand c) 
-                       (\e -> io (hPutStr stdout ("Error: " ++ show e)))
+runCommand c = 
+  myCatchDyn (doCommand c) 
+    (\dyn -> case dyn of
+               PhaseFailed phase code ->
+                       io ( putStrLn ("Phase " ++ phase ++ " failed (code "
+                                       ++ show code ++ ")"))
+               Interrupted -> io (putStrLn "Interrupted.")
+               _ -> io (putStrLn (show (dyn :: BarfKind)))
+    )
 
 doCommand (':' : command) = specialCommand command
 doCommand expr = do
+  st <- getGHCiState
   io (hPutStrLn stdout ("Run expression: " ++ expr))
+  let (mod,'.':str) = break (=='.') expr
+  case cmLookupSymbol (mkOrig varName (mkModuleName mod) (_PK_ str)) (cmstate st) of
+       Nothing -> io (putStrLn "nothing.")
+       Just e  -> io (do unsafeCoerce# e :: IO ()
+                         putStrLn "done.")
   return ()
 
 specialCommand str = do
@@ -114,10 +133,11 @@ specialCommand str = do
   case [ (s,f) | (s,f) <- commands, prefixMatch cmd s ] of
      []      -> io $ hPutStr stdout ("uknown command `:" ++ cmd ++ "'\n" 
                                    ++ shortHelpText)
-     [(_,f)] -> f rest
+     [(_,f)] -> f (dropWhile isSpace rest)
      cs      -> io $ hPutStrLn stdout ("prefix " ++ cmd ++ 
                                       " matches multiple commands (" ++ 
-                                      foldr1 (\a b -> a ++ ',':b) (map fst cs) ++ ")")
+                                      foldr1 (\a b -> a ++ ',':b) (map fst cs)
+                                        ++ ")")
 
 noArgs c = io (hPutStrLn stdout ("command `:" ++ c ++ "' takes no arguments"))
 
@@ -180,7 +200,10 @@ setGHCiState s = GHCi $ \_ -> return (s,())
 
 io m = GHCi $ \s -> m >>= \a -> return (s,a)
 
-myCatch (GHCi m) h = GHCi $ \s -> Exception.catch (m s) (\e -> unGHCi (h e) s)
+myCatch (GHCi m) h = GHCi $ \s -> 
+   Exception.catch (m s) (\e -> unGHCi (h e) s)
+myCatchDyn (GHCi m) h = GHCi $ \s -> 
+   Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
 
 -----------------------------------------------------------------------------
 -- package loader