From 292c077de7dbe98eb44911648f16e243b40db2ac Mon Sep 17 00:00:00 2001 From: simonmar Date: Thu, 16 Nov 2000 11:39:37 +0000 Subject: [PATCH] [project @ 2000-11-16 11:39:36 by simonmar] Current state of the interactive system; can load packages (in theory). --- ghc/compiler/Makefile | 8 +++--- ghc/compiler/basicTypes/Module.lhs | 1 - ghc/compiler/compMan/CmLink.lhs | 2 +- ghc/compiler/ghci/InteractiveUI.hs | 53 ++++++++++++++++++++++++++++++++---- ghc/compiler/ghci/Linker.lhs | 42 ++-------------------------- ghc/compiler/main/DriverState.hs | 45 ++++++++++++++---------------- ghc/compiler/main/DriverUtil.hs | 3 +- ghc/compiler/main/HscMain.lhs | 5 ++-- ghc/compiler/main/Main.hs | 30 ++++++-------------- ghc/compiler/parser/Lex.lhs | 2 ++ ghc/compiler/parser/Parser.y | 15 ++++++++-- 11 files changed, 105 insertions(+), 101 deletions(-) diff --git a/ghc/compiler/Makefile b/ghc/compiler/Makefile index 0cdd97a..a10ac7d 100644 --- a/ghc/compiler/Makefile +++ b/ghc/compiler/Makefile @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $Id: Makefile,v 1.113 2000/11/10 14:29:20 simonmar Exp $ +# $Id: Makefile,v 1.114 2000/11/16 11:39:36 simonmar Exp $ TOP = .. include $(TOP)/mk/boilerplate.mk @@ -175,12 +175,12 @@ SRC_HC_OPTS += \ ghc_407_at_least = $(shell expr "$(GhcMinVersion)" \>= 7) ifeq "$(ghc_407_at_least)" "1" ifneq "$(mingw32_TARGET_OS)" "1" -SRC_HC_OPTS += -package concurrent -package posix -package text +SRC_HC_OPTS += -package concurrent -package posix -package text -package util else -SRC_HC_OPTS += -package concurrent -package text +SRC_HC_OPTS += -package concurrent -package text -package util endif else -SRC_HC_OPTS += -syslib concurrent -syslib posix -syslib misc +SRC_HC_OPTS += -syslib concurrent -syslib posix -syslib misc -syslib util endif SRC_CC_OPTS += -Iparser -I. -I$(TOP)/includes -O diff --git a/ghc/compiler/basicTypes/Module.lhs b/ghc/compiler/basicTypes/Module.lhs index b12ba5d..5676bc2 100644 --- a/ghc/compiler/basicTypes/Module.lhs +++ b/ghc/compiler/basicTypes/Module.lhs @@ -33,7 +33,6 @@ module Module , moduleString -- :: Module -> EncodedString , moduleUserString -- :: Module -> UserString - , moduleName -- :: Module -> ModuleName , mkVanillaModule -- :: ModuleName -> Module , mkPrelModule -- :: UserString -> Module diff --git a/ghc/compiler/compMan/CmLink.lhs b/ghc/compiler/compMan/CmLink.lhs index 9940eca..811601b 100644 --- a/ghc/compiler/compMan/CmLink.lhs +++ b/ghc/compiler/compMan/CmLink.lhs @@ -18,6 +18,7 @@ import Interpreter import CmStaticInfo ( PackageConfigInfo, GhciMode(..) ) import Module ( ModuleName, PackageName ) import Outputable ( SDoc ) +import FiniteMap import Digraph ( SCC(..), flattenSCC ) import Outputable import Panic ( panic ) @@ -145,7 +146,6 @@ link doLink Interactive batch_attempt_linking linkables pls1 = do putStrLn "LINKER(interactive): not yet implemented" return (LinkOK pls1) - ppLinkableSCC :: SCC Linkable -> SDoc ppLinkableSCC = ppr . flattenSCC diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index fd7f542..f4193fc 100644 --- a/ghc/compiler/ghci/InteractiveUI.hs +++ b/ghc/compiler/ghci/InteractiveUI.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: InteractiveUI.hs,v 1.1 2000/11/16 10:48:22 simonmar Exp $ +-- $Id: InteractiveUI.hs,v 1.2 2000/11/16 11:39:37 simonmar Exp $ -- -- GHC Interactive User Interface -- @@ -7,14 +7,20 @@ -- ----------------------------------------------------------------------------- -module InteractiveUI where +module InteractiveUI (interactiveUI) where import CompManager +import CmStaticInfo +import DriverUtil +import DriverState +import Linker import Module import Panic import Util +import Exception import Readline +import IOExts import System import Directory @@ -61,9 +67,14 @@ helpText = "\ interactiveUI :: CmState -> IO () interactiveUI st = do - hPutStr stdout ghciWelcomeMsg + hPutStrLn stdout ghciWelcomeMsg hFlush stdout hSetBuffering stdout NoBuffering + + -- link in the available packages + pkgs <- getPackageInfo + linkPackages (reverse pkgs) + #ifndef NO_READLINE Readline.initialize #endif @@ -108,7 +119,7 @@ specialCommand str = do " matches multiple commands (" ++ foldr1 (\a b -> a ++ ',':b) (map fst cs) ++ ")") -noArgs c = io (hPutStr stdout ("command `:" ++ c ++ "' takes no arguments")) +noArgs c = io (hPutStrLn stdout ("command `:" ++ c ++ "' takes no arguments")) ----------------------------------------------------------------------------- -- Commands @@ -131,7 +142,7 @@ reloadModule :: String -> GHCi () reloadModule "" = do state <- getGHCiState case target state of - Nothing -> io (hPutStr stdout "no current target") + Nothing -> io (putStr "no current target\n") Just path -> do (new_cmstate, mod) <- io (cmLoadModule (cmstate state) (mkModuleName path)) setGHCiState state{cmstate=new_cmstate} reloadModule _ = noArgs ":reload" @@ -169,4 +180,34 @@ setGHCiState s = GHCi $ \_ -> return (s,()) io m = GHCi $ \s -> m >>= \a -> return (s,a) -myCatch (GHCi m) h = GHCi $ \s -> catch (m s) (\e -> unGHCi (h e) s) +myCatch (GHCi m) h = GHCi $ \s -> Exception.catch (m s) (\e -> unGHCi (h e) s) + +----------------------------------------------------------------------------- +-- package loader + +linkPackages :: [Package] -> IO () +linkPackages pkgs = mapM_ linkPackage pkgs + +linkPackage :: Package -> IO () +-- ignore rts and gmp for now (ToDo; better?) +linkPackage pkg | name pkg `elem` ["rts", "gmp"] = return () +linkPackage pkg = do + putStr ("Loading package " ++ name pkg ++ " ... ") + let dirs = library_dirs pkg + let objs = map (++".o") (hs_libraries pkg ++ extra_libraries pkg) + mapM (linkOneObj dirs) objs + putStr "resolving ... " + resolveObjs + putStrLn "done." + +linkOneObj dirs obj = do + filename <- findFile dirs obj + loadObj filename + +findFile [] obj = throwDyn (OtherError ("can't find " ++ obj)) +findFile (d:ds) obj = do + let path = d ++ '/':obj + b <- doesFileExist path + if b then return path else findFile ds obj + + diff --git a/ghc/compiler/ghci/Linker.lhs b/ghc/compiler/ghci/Linker.lhs index 440ff11..c876b0a 100644 --- a/ghc/compiler/ghci/Linker.lhs +++ b/ghc/compiler/ghci/Linker.lhs @@ -10,47 +10,13 @@ module Linker ( unloadObj, -- :: String -> IO () lookupSymbol, -- :: String -> IO (Maybe Addr) resolveObjs, -- :: IO () - linkPrelude -- tmp ) where -import IO -import Exception import Addr import PrelByteArr import PrelPack (packString) import Panic ( panic ) -#if __GLASGOW_HASKELL__ <= 408 -loadObj = bogus "loadObj" -unloadObj = bogus "unloadObj" -lookupSymbol = bogus "lookupSymbol" -resolveObjs = bogus "resolveObjs" -linkPrelude = bogus "linkPrelude" -bogus f = panic ("Linker." ++ f ++ ": this hsc was built without an interpreter.") - -#else - -linkPrelude = do - hPutStr stderr "Loading HSstd_cbits.o..." - loadObj "/home/simonmar/builds/i386-unknown-linux-boot/ghc/lib/std/cbits/HSstd_cbits.o" - hPutStr stderr "done.\n" - hPutStr stderr "Resolving..." - resolveObjs - hPutStr stderr "done.\n" - hPutStr stderr "Loading HSstd.o..." - loadObj "/home/simonmar/builds/i386-unknown-linux-boot/ghc/lib/std/HSstd.o" - hPutStr stderr "done.\n" - hPutStr stderr "Resolving..." - resolveObjs - hPutStr stderr "done.\n" -{- - hPutStr stderr "Unloading HSstd.o..." - unloadObj "/home/simonmar/builds/i386-unknown-linux-boot/ghc/lib/std/HSstd.o" - hPutStr stderr "done.\n" - unloadObj "/home/simonmar/builds/i386-unknown-linux-boot/ghc/lib/std/cbits/HSstd_cbits.o" - hPutStr stderr "done.\n" --} - -- --------------------------------------------------------------------------- -- RTS Linker Interface -- --------------------------------------------------------------------------- @@ -64,19 +30,19 @@ lookupSymbol str = do loadObj str = do r <- c_loadObj (packString str) if (r == 0) - then error "loadObj: failed" + then panic "loadObj: failed" else return () unloadObj str = do r <- c_unloadObj (packString str) if (r == 0) - then error "unloadObj: failed" + then panic "unloadObj: failed" else return () resolveObjs = do r <- c_resolveObjs if (r == 0) - then error "resolveObjs: failed" + then panic "resolveObjs: failed" else return () @@ -93,6 +59,4 @@ foreign import "unloadObj" unsafe foreign import "resolveObjs" unsafe c_resolveObjs :: IO Int - -#endif /* __GLASGOW_HASKELL__ <= 408 */ \end{code} diff --git a/ghc/compiler/main/DriverState.hs b/ghc/compiler/main/DriverState.hs index d6ee6d0..4b94d28 100644 --- a/ghc/compiler/main/DriverState.hs +++ b/ghc/compiler/main/DriverState.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverState.hs,v 1.13 2000/11/14 16:28:38 simonmar Exp $ +-- $Id: DriverState.hs,v 1.14 2000/11/16 11:39:37 simonmar Exp $ -- -- Settings for the driver -- @@ -439,56 +439,53 @@ addPackage package getPackageImportPath :: IO [String] getPackageImportPath = do - ps <- readIORef v_Packages - ps' <- getPackageDetails ps - return (nub (concat (map import_dirs ps'))) + ps <- getPackageInfo + return (nub (concat (map import_dirs ps))) getPackageIncludePath :: IO [String] getPackageIncludePath = do - ps <- readIORef v_Packages - ps' <- getPackageDetails ps - return (nub (filter (not.null) (concatMap include_dirs ps'))) + ps <- getPackageInfo + return (nub (filter (not.null) (concatMap include_dirs ps))) -- includes are in reverse dependency order (i.e. rts first) getPackageCIncludes :: IO [String] getPackageCIncludes = do - ps <- readIORef v_Packages - ps' <- getPackageDetails ps - return (reverse (nub (filter (not.null) (concatMap c_includes ps')))) + ps <- getPackageInfo + return (reverse (nub (filter (not.null) (concatMap c_includes ps)))) getPackageLibraryPath :: IO [String] getPackageLibraryPath = do - ps <- readIORef v_Packages - ps' <- getPackageDetails ps - return (nub (concat (map library_dirs ps'))) + ps <- getPackageInfo + return (nub (concat (map library_dirs ps))) getPackageLibraries :: IO [String] getPackageLibraries = do - ps <- readIORef v_Packages - ps' <- getPackageDetails ps + ps <- getPackageInfo tag <- readIORef v_Build_tag let suffix = if null tag then "" else '_':tag return (concat ( - map (\p -> map (++suffix) (hs_libraries p) ++ extra_libraries p) ps' + map (\p -> map (++suffix) (hs_libraries p) ++ extra_libraries p) ps )) getPackageExtraGhcOpts :: IO [String] getPackageExtraGhcOpts = do - ps <- readIORef v_Packages - ps' <- getPackageDetails ps - return (concatMap extra_ghc_opts ps') + ps <- getPackageInfo + return (concatMap extra_ghc_opts ps) getPackageExtraCcOpts :: IO [String] getPackageExtraCcOpts = do - ps <- readIORef v_Packages - ps' <- getPackageDetails ps - return (concatMap extra_cc_opts ps') + ps <- getPackageInfo + return (concatMap extra_cc_opts ps) getPackageExtraLdOpts :: IO [String] getPackageExtraLdOpts = do + ps <- getPackageInfo + return (concatMap extra_ld_opts ps) + +getPackageInfo :: IO [Package] +getPackageInfo = do ps <- readIORef v_Packages - ps' <- getPackageDetails ps - return (concatMap extra_ld_opts ps') + getPackageDetails ps getPackageDetails :: [String] -> IO [Package] getPackageDetails ps = do diff --git a/ghc/compiler/main/DriverUtil.hs b/ghc/compiler/main/DriverUtil.hs index 8215996..7d6e6eb 100644 --- a/ghc/compiler/main/DriverUtil.hs +++ b/ghc/compiler/main/DriverUtil.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverUtil.hs,v 1.6 2000/11/10 14:29:21 simonmar Exp $ +-- $Id: DriverUtil.hs,v 1.7 2000/11/16 11:39:37 simonmar Exp $ -- -- Utils for the driver -- @@ -70,6 +70,7 @@ instance Typeable BarfKind where ----------------------------------------------------------------------------- -- Reading OPTIONS pragmas + getOptionsFromSource :: String -- input file -> IO [String] -- options, if any diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 467306c..3ba9df3 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -14,7 +14,7 @@ import IO ( hPutStrLn, stderr ) import HsSyn import StringBuffer ( hGetStringBuffer ) -import Parser ( parse ) +import Parser import Lex ( PState(..), ParseResult(..) ) import SrcLoc ( mkSrcLoc ) @@ -263,7 +263,8 @@ myParseModule dflags src_filename PFailed err -> do { hPutStrLn stderr (showSDoc err); return Nothing }; - POk _ rdr_module@(HsModule mod_name _ _ _ _ _ _) -> do { + + POk _ (PModule rdr_module@(HsModule mod_name _ _ _ _ _ _)) -> do { dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ; diff --git a/ghc/compiler/main/Main.hs b/ghc/compiler/main/Main.hs index 109af75..8283eb5 100644 --- a/ghc/compiler/main/Main.hs +++ b/ghc/compiler/main/Main.hs @@ -1,6 +1,6 @@ {-# OPTIONS -W -fno-warn-incomplete-patterns #-} ----------------------------------------------------------------------------- --- $Id: Main.hs,v 1.22 2000/11/15 10:49:54 sewardj Exp $ +-- $Id: Main.hs,v 1.23 2000/11/16 11:39:37 simonmar Exp $ -- -- GHC Driver program -- @@ -16,6 +16,7 @@ module Main (main) where #include "HsVersions.h" import CompManager +import InteractiveUI import DriverPipeline import DriverState import DriverFlags @@ -281,25 +282,12 @@ beginMake pkg_details mods _ -> throwDyn (UsageError "only one module allowed with --make") beginInteractive pkg_details mods - = do case mods of - [] -> return () - [mod] -> do state <- cmInit pkg_details Interactive - cmLoadModule state (mkModuleName mod) - return () - _ -> throwDyn (UsageError + = do state <- cmInit pkg_details Interactive + case mods of + [] -> return () + [mod] -> do cmLoadModule state (mkModuleName mod); return () + _ -> throwDyn (UsageError "only one module allowed with --interactive") - interactiveUI - -interactiveUI :: IO () -interactiveUI = do - hPutStr stdout ghciWelcomeMsg - throwDyn (OtherError "GHCi not implemented yet") - -ghciWelcomeMsg = "\ -\ _____ __ __ ____ ------------------------------------------------\n\ -\(| || || (| |) GHCi: GHC Interactive, version 5.00 \n\ -\|| __ ||___|| || () For Haskell 98. \n\ -\|| |) ||---|| || // http://www.haskell.org/ghc \n\ -\|| || || || || // Bug reports to: glasgow-haskell-bugs@haskell.org\n\ -\(|___|| || || (|__|) (| ________________________________________________\n" + interactiveUI state + diff --git a/ghc/compiler/parser/Lex.lhs b/ghc/compiler/parser/Lex.lhs index 6c69738..9cd6567 100644 --- a/ghc/compiler/parser/Lex.lhs +++ b/ghc/compiler/parser/Lex.lhs @@ -123,6 +123,7 @@ data Token | ITccallconv | ITinterface -- interface keywords + | ITexpr | IT__export | ITdepends | IT__forall @@ -295,6 +296,7 @@ ghcExtensionKeywordsFM = listToUFM $ -- interface keywords ("__interface", ITinterface), + ("__expr", ITexpr), ("__export", IT__export), ("__depends", ITdepends), ("__forall", IT__forall), diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index 779c235..9dc85a2 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- ----------------------------------------------------------------------------- -$Id: Parser.y,v 1.47 2000/11/07 15:21:40 simonmar Exp $ +$Id: Parser.y,v 1.48 2000/11/16 11:39:37 simonmar Exp $ Haskell grammar. @@ -9,7 +9,7 @@ Author(s): Simon Marlow, Sven Panne 1997, 1998, 1999 -} { -module Parser ( parse ) where +module Parser ( ParseStuff(..), parse ) where import HsSyn import HsTypes ( mkHsTupCon ) @@ -113,6 +113,8 @@ Conflicts: 14 shift/reduce '{-# DEPRECATED' { ITdeprecated_prag } '#-}' { ITclose_prag } + '__expr' { ITexpr } + {- '__interface' { ITinterface } -- interface keywords '__export' { IT__export } @@ -202,6 +204,13 @@ Conflicts: 14 shift/reduce %% ----------------------------------------------------------------------------- +-- Entry points + +parse :: { ParseStuff } + : module { PModule $1 } + | '__expr' exp { PExpr $2 } + +----------------------------------------------------------------------------- -- Module Header -- The place for module deprecation is really too restrictive, but if it @@ -1096,6 +1105,8 @@ commas :: { Int } ----------------------------------------------------------------------------- { +data ParseStuff = PModule RdrNameHsModule | PExpr RdrNameHsExpr + happyError :: P a happyError buf PState{ loc = loc } = PFailed (srcParseErr buf loc) } -- 1.7.10.4