X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FGHC.hs;h=be47c76a460bab0bbb9b092f9f1e6aff22f939f0;hb=1717c5831d71bfa63f9d098a2a709feb2d8fbcc9;hp=5fcfd1dbcaebe2f68f73488c89e7ef90090a7f22;hpb=49c3ce56f68a9de28741b6de3d85821360d8561e;p=ghc-hetmet.git

diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 5fcfd1d..be47c76 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -11,13 +11,11 @@ module GHC (
 	Session,
 	defaultErrorHandler,
 	defaultCleanupHandler,
-	init, initFromArgs,
 	newSession,
 
 	-- * Flags and settings
 	DynFlags(..), DynFlag(..), Severity(..), GhcMode(..), HscTarget(..), dopt,
 	parseDynamicFlags,
-	initPackages,
 	getSessionDynFlags,
 	setSessionDynFlags,
 
@@ -78,7 +76,7 @@ module GHC (
 	RunResult(..),
 	runStmt,
 	showModule,
-	compileExpr, HValue,
+	compileExpr, HValue, dynCompileExpr,
 	lookupName,
 #endif
 
@@ -166,8 +164,6 @@ module GHC (
  ToDo:
 
   * inline bits of HscMain here to simplify layering: hscTcExpr, hscStmt.
-  * we need to expose DynFlags, so should parseDynamicFlags really be
-    part of this interface?
   * what StaticFlags should we expose, if any?
 -}
 
@@ -175,6 +171,7 @@ module GHC (
 
 #ifdef GHCI
 import qualified Linker
+import Data.Dynamic     ( Dynamic )
 import Linker		( HValue, extendLinkEnv )
 import TcRnDriver	( tcRnLookupRdrName, tcRnGetInfo,
 			  tcRnLookupName, getModuleExports )
@@ -226,10 +223,11 @@ import Finder
 import HscMain		( newHscEnv, hscFileCheck, HscChecked(..) )
 import HscTypes
 import DynFlags
-import SysTools		( initSysTools, cleanTempFiles, cleanTempFilesExcept )
+import SysTools     ( initSysTools, cleanTempFiles, cleanTempFilesExcept,
+                      cleanTempDirs )
 import Module
 import UniqFM
-import PackageConfig    ( PackageId )
+import PackageConfig    ( PackageId, stringToPackageId )
 import FiniteMap
 import Panic
 import Digraph
@@ -309,55 +307,30 @@ defaultErrorHandler dflags inner =
 -- handling, but still get the ordinary cleanup behaviour.
 defaultCleanupHandler :: DynFlags -> IO a -> IO a
 defaultCleanupHandler dflags inner = 
-   -- make sure we clean up after ourselves
-   later (unless (dopt Opt_KeepTmpFiles dflags) $ 
-	    cleanTempFiles dflags) 
-	-- exceptions will be blocked while we clean the temporary files,
-	-- so there shouldn't be any difficulty if we receive further
-	-- signals.
-   inner
-
-
--- | Initialises GHC.  This must be done /once/ only.  Takes the
--- TopDir path without the '-B' prefix.
-
-init :: Maybe String -> IO ()
-init mbMinusB = do
-   -- catch ^C
-   main_thread <- myThreadId
-   putMVar interruptTargetThread [main_thread]
-   installSignalHandlers
-
-   dflags0 <- initSysTools mbMinusB defaultDynFlags
-   writeIORef v_initDynFlags dflags0
-
--- | Initialises GHC. This must be done /once/ only. Takes the
--- command-line arguments.  All command-line arguments which aren't
--- understood by GHC will be returned.
-
-initFromArgs :: [String] -> IO [String]
-initFromArgs args
-    = do init mbMinusB
-         return argv1
-    where -- Grab the -B option if there is one
-          (minusB_args, argv1) = partition (prefixMatch "-B") args
-          mbMinusB | null minusB_args
-                       = Nothing
-                   | otherwise
-                       = Just (drop 2 (last minusB_args))
-
-GLOBAL_VAR(v_initDynFlags, error "initDynFlags", DynFlags)
-	-- stores the DynFlags between the call to init and subsequent
-	-- calls to newSession.
+    -- make sure we clean up after ourselves
+    later (unless (dopt Opt_KeepTmpFiles dflags) $
+               do cleanTempFiles dflags
+                  cleanTempDirs dflags
+          )
+          -- exceptions will be blocked while we clean the temporary files,
+          -- so there shouldn't be any difficulty if we receive further
+          -- signals.
+    inner
+
 
 -- | Starts a new session.  A session consists of a set of loaded
 -- modules, a set of options (DynFlags), and an interactive context.
 -- ToDo: GhcMode should say "keep typechecked code" and\/or "keep renamed
 -- code".
-newSession :: GhcMode -> IO Session
-newSession mode = do
-  dflags0 <- readIORef v_initDynFlags
-  dflags <- initDynFlags dflags0
+newSession :: GhcMode -> Maybe FilePath -> IO Session
+newSession mode mb_top_dir = do
+  -- catch ^C
+  main_thread <- myThreadId
+  putMVar interruptTargetThread [main_thread]
+  installSignalHandlers
+
+  dflags0 <- initSysTools mb_top_dir defaultDynFlags
+  dflags  <- initDynFlags dflags0
   env <- newHscEnv dflags{ ghcMode=mode }
   ref <- newIORef env
   return (Session ref)
@@ -380,9 +353,23 @@ modifySession (Session ref) f = do h <- readIORef ref; writeIORef ref $! f h
 getSessionDynFlags :: Session -> IO DynFlags
 getSessionDynFlags s = withSession s (return . hsc_dflags)
 
--- | Updates the DynFlags in a Session
-setSessionDynFlags :: Session -> DynFlags -> IO ()
-setSessionDynFlags s dflags = modifySession s (\h -> h{ hsc_dflags = dflags })
+-- | Updates the DynFlags in a Session.  This also reads
+-- the package database (unless it has already been read),
+-- and prepares the compilers knowledge about packages.  It
+-- can be called again to load new packages: just add new
+-- package flags to (packageFlags dflags).
+--
+-- Returns a list of new packages that may need to be linked in using
+-- the dynamic linker (see 'linkPackages') as a result of new package
+-- flags.  If you are not doing linking or doing static linking, you
+-- can ignore the list of packages returned.
+--
+setSessionDynFlags :: Session -> DynFlags -> IO [PackageId]
+setSessionDynFlags (Session ref) dflags = do
+  hsc_env <- readIORef ref
+  (dflags', preload) <- initPackages dflags
+  writeIORef ref $! hsc_env{ hsc_dflags = dflags' }
+  return preload
 
 -- | If there is no -o option, guess the name of target executable
 -- by using top-level source file name as a base.
@@ -1628,7 +1615,7 @@ preprocessFile dflags src_fn mb_phase (Just (buf, time))
 noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> IO ab
 -- ToDo: we don't have a proper line number for this error
 noModError dflags loc wanted_mod err
-  = throwDyn $ mkPlainErrMsg loc $ cantFindError dflags wanted_mod err
+  = throwDyn $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err
 				
 noHsFileErr loc path
   = throwDyn $ mkPlainErrMsg loc $ text "Can't find" <+> text path
@@ -1846,8 +1833,10 @@ findModule' hsc_env mod_name maybe_pkg =
 	  res <- findImportedModule hsc_env mod_name Nothing
 	  case res of
 	    Found _ m | modulePackageId m /= this_pkg -> return m
-                        -- not allowed to be a home module
-	    err -> let msg = cantFindError dflags mod_name err in
+		      | otherwise -> throwDyn (CmdLineError (showSDoc $
+					text "module" <+> pprModule m <+>
+					text "is not loaded"))
+	    err -> let msg = cannotFindModule dflags mod_name err in
 		   throwDyn (CmdLineError (showSDoc msg))
 
 #ifdef GHCI
@@ -2016,6 +2005,27 @@ compileExpr s expr = withSession s $ \hsc_env -> do
 		  _ 	     -> panic "compileExpr"
 
 -- -----------------------------------------------------------------------------
+-- Compile an expression into a dynamic
+
+dynCompileExpr :: Session -> String -> IO (Maybe Dynamic)
+dynCompileExpr ses expr = do
+    (full,exports) <- getContext ses
+    setContext ses full $
+        (mkModule
+            (stringToPackageId "base") (mkModuleName "Data.Dynamic")
+        ):exports
+    let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")"
+    res <- withSession ses (flip hscStmt stmt)
+    setContext ses full exports
+    case res of
+        Nothing -> return Nothing
+        Just (_, names, hvals) -> do
+            vals <- (unsafeCoerce# hvals :: IO [Dynamic])
+            case (names,vals) of
+                (_:[], v:[])    -> return (Just v)
+                _               -> panic "dynCompileExpr"
+
+-- -----------------------------------------------------------------------------
 -- running a statement interactively
 
 data RunResult