From: simonmar Date: Thu, 16 Nov 2000 16:54:36 +0000 (+0000) Subject: [project @ 2000-11-16 16:54:36 by simonmar] X-Git-Tag: Approximately_9120_patches~3322 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=2bf08ae10e95b0ea98189118f6801dc3c62aa495;p=ghc-hetmet.git [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 --- 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 --- 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 --- 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