[project @ 2000-11-21 16:42:58 by simonmar]

Bugfixes, bugfixes:

  - allow compiling expressions in the context of any module we have
    an interface for, including "Prelude".
  - don't forget to pull in things like unpackCString# in the renamer,
    we might need to use them for desugaring Strings, for example.  I'm
    sure there are other things we'll need to pull in too.
  - :quit now works from the interpreter (!)

diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs
index 97071d7..0ea9799 100644 (file)
--- a/ghc/compiler/ghci/InteractiveUI.hs
+++ b/ghc/compiler/ghci/InteractiveUI.hs
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------------
--- $Id: InteractiveUI.hs,v 1.9 2000/11/21 15:00:58 simonmar Exp $
+-- $Id: InteractiveUI.hs,v 1.10 2000/11/21 16:42:58 simonmar Exp $
 --
 -- GHC Interactive User Interface
 --
@@ -96,7 +96,7 @@ uiLoop = do
   l <- io (hGetLine stdin)
 #endif
   case l of
-    Nothing -> return ()
+    Nothing -> exitGHCi
     Just "" -> uiLoop
     Just l  -> do
 #ifndef NO_READLINE
@@ -105,6 +105,8 @@ uiLoop = do
          runCommand l
          uiLoop  
 
+exitGHCi = io $ do putStrLn "Leaving GHCi."; exitWith ExitSuccess
+
 -- Top level exception handler, just prints out the exception 
 -- and carries on.
 runCommand c = 
@@ -226,7 +228,7 @@ typeOfExpr str
         Just ty -> io (putStrLn (showSDoc (ppr ty)))
 
 quit :: String -> GHCi ()
-quit _ = return ()
+quit _ = exitGHCi
 
 shellEscape :: String -> GHCi ()
 shellEscape str = io (system str >> return ())

diff --git a/ghc/compiler/ghci/StgInterp.lhs b/ghc/compiler/ghci/StgInterp.lhs
index 44ddf69..9a452b5 100644 (file)
--- a/ghc/compiler/ghci/StgInterp.lhs
+++ b/ghc/compiler/ghci/StgInterp.lhs
@@ -82,8 +82,8 @@ import RdrName                ( RdrName, rdrNameModule, rdrNameOcc )
 import FiniteMap
 import Panic           ( panic )
 import OccName         ( occNameString )
-import ErrUtils                ( showPass )
-import CmdLineOpts     ( DynFlags )
+import ErrUtils                ( showPass, dumpIfSet_dyn )
+import CmdLineOpts     ( DynFlags, DynFlag(..) )
 
 import Foreign
 import CTypes
@@ -122,6 +122,8 @@ stgBindsToInterpSyn dflags binds local_tycons local_classes
  = do showPass dflags "StgToInterp"
       let ibinds = concatMap (translateBind emptyUniqSet) binds
       let tycs   = local_tycons ++ map classTyCon local_classes
+      dumpIfSet_dyn dflags Opt_D_dump_InterpSyn
+        "Convert To InterpSyn" (vcat (map pprIBind ibinds))
       itblenv <- mkITbls tycs
       return (ibinds, itblenv)
 
@@ -130,7 +132,10 @@ stgExprToInterpSyn :: DynFlags
                   -> IO UnlinkedIExpr
 stgExprToInterpSyn dflags expr
  = do showPass dflags "StgToInterp"
-      return (stg2expr emptyUniqSet expr)
+      let iexpr = stg2expr emptyUniqSet expr
+      dumpIfSet_dyn dflags Opt_D_dump_InterpSyn
+       "Convert To InterpSyn" (pprIExpr iexpr)
+      return iexpr
 
 translateBind :: UniqSet Id -> StgBinding -> [UnlinkedIBind]
 translateBind ie (StgNonRec v e)  = [IBind v (rhs2expr ie e)]

diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs
index bf00769..731678b 100644 (file)
--- a/ghc/compiler/main/CmdLineOpts.lhs
+++ b/ghc/compiler/main/CmdLineOpts.lhs
@@ -243,6 +243,7 @@ data DynFlag
    | Opt_D_dump_rn_stats
    | Opt_D_dump_stix
    | Opt_D_dump_simpl_stats
+   | Opt_D_dump_InterpSyn
    | Opt_D_source_stats
    | Opt_D_verbose_core2core
    | Opt_D_verbose_stg2stg

diff --git a/ghc/compiler/main/DriverFlags.hs b/ghc/compiler/main/DriverFlags.hs
index cf336d0..5050f28 100644 (file)
--- a/ghc/compiler/main/DriverFlags.hs
+++ b/ghc/compiler/main/DriverFlags.hs
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------------
--- $Id: DriverFlags.hs,v 1.21 2000/11/21 14:34:29 simonmar Exp $
+-- $Id: DriverFlags.hs,v 1.22 2000/11/21 16:43:20 simonmar Exp $
 --
 -- Driver flags
 --
@@ -391,6 +391,7 @@ dynamic_flags = [
   ,  ( "ddump-rn-stats",         NoArg (setDynFlag Opt_D_dump_rn_stats) )
   ,  ( "ddump-stix",             NoArg (setDynFlag Opt_D_dump_stix) )
   ,  ( "ddump-simpl-stats",      NoArg (setDynFlag Opt_D_dump_simpl_stats) )
+  ,  ( "ddump-interpsyn",        NoArg (setDynFlag Opt_D_dump_InterpSyn) )
   ,  ( "dsource-stats",          NoArg (setDynFlag Opt_D_source_stats) )
   ,  ( "dverbose-core2core",     NoArg (setDynFlag Opt_D_verbose_core2core) )
   ,  ( "dverbose-stg2stg",       NoArg (setDynFlag Opt_D_verbose_stg2stg) )

diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs
index 67195e2..427dce8 100644 (file)
--- a/ghc/compiler/rename/Rename.lhs
+++ b/ghc/compiler/rename/Rename.lhs
@@ -27,11 +27,14 @@ import RnIfaces             ( slurpImpDecls, mkImportInfo, recordLocalSlurps,
                          RecompileRequired, outOfDate, recompileRequired
                        )
 import RnHiFiles       ( readIface, removeContext, loadInterface,
-                         loadExports, loadFixDecls, loadDeprecs )
+                         loadExports, loadFixDecls, loadDeprecs,
+                         tryLoadInterface )
 import RnEnv           ( availsToNameSet, availName, mkIfaceGlobalRdrEnv,
-                         emptyAvailEnv, unitAvailEnv, availEnvElts, plusAvailEnv, groupAvails,
-                         warnUnusedImports, warnUnusedLocalBinds, warnUnusedModules,
-                         lookupOrigNames, lookupSrcName, newGlobalName, unQualInScope
+                         emptyAvailEnv, unitAvailEnv, availEnvElts, 
+                         plusAvailEnv, groupAvails, warnUnusedImports, 
+                         warnUnusedLocalBinds, warnUnusedModules, 
+                         lookupOrigNames, lookupSrcName, 
+                         newGlobalName, unQualInScope
                        )
 import Module           ( Module, ModuleName, WhereFrom(..),
                          moduleNameUserString, moduleName,
@@ -101,25 +104,38 @@ renameExpr :: DynFlags
           -> HomeIfaceTable -> HomeSymbolTable
           -> PersistentCompilerState 
           -> Module -> RdrNameHsExpr
-          -> IO (PersistentCompilerState, Maybe (PrintUnqualified, (RenamedHsExpr, [RenamedHsDecl])))
+          -> IO ( PersistentCompilerState, 
+                  Maybe (PrintUnqualified, (RenamedHsExpr, [RenamedHsDecl]))
+                 )
 
 renameExpr dflags hit hst pcs this_module expr
-  | Just iface <- lookupModuleEnv hit this_module
-  = do { let rdr_env      = mi_globals iface
-       ; let print_unqual = unQualInScope rdr_env
-         
-       ; renameSource dflags hit hst pcs this_module $
-         initRnMS rdr_env emptyLocalFixityEnv SourceMode (rnExpr expr) `thenRn` \ (e,fvs) -> 
-         slurpImpDecls fvs                                             `thenRn` \ decls ->
-         doptRn Opt_D_dump_rn                                          `thenRn` \ dump_rn ->
-         ioToRnM (dumpIfSet dump_rn "Renamer:" (ppr e))                `thenRn_`
+  = do { renameSource dflags hit hst pcs this_module $
+         tryLoadInterface doc (moduleName this_module) ImportByUser 
+                                               `thenRn` \ (iface, maybe_err) ->
+         case maybe_err of {
+           Just msg -> ioToRnM (printErrs alwaysQualify 
+                                (ptext SLIT("failed to load interface for") 
+                                 <+> quotes (ppr this_module) 
+                                 <>  char ':' <+> msg)) `thenRn_`
+                       returnRn Nothing;
+           Nothing -> 
+
+         let rdr_env      = mi_globals iface
+             print_unqual = unQualInScope rdr_env
+         in 
+ 
+         initRnMS rdr_env emptyLocalFixityEnv SourceMode (rnExpr expr) 
+                                               `thenRn` \ (e,fvs) -> 
+         lookupOrigNames implicit_occs         `thenRn` \ implicit_names ->
+         slurpImpDecls (fvs `plusFV` implicit_names) `thenRn` \ decls ->
+         doptRn Opt_D_dump_rn                  `thenRn` \ dump_rn ->
+         ioToRnM (dumpIfSet dump_rn "Renamer:" (ppr e))
+                                               `thenRn_`
          returnRn (Just (print_unqual, (e, decls)))
-       }
-
-  | otherwise
-  = do { printErrs alwaysQualify (ptext SLIT("renameExpr: Bad module context") <+> ppr this_module)
-       ; return (pcs, Nothing)
-       }
+       }}
+  where
+     implicit_occs = string_occs
+     doc = text "context for compiling expression"
 \end{code}
 
 
@@ -297,9 +313,6 @@ implicitFVs mod_name decls
        -- generate code
     implicit_occs = string_occs ++ foldr ((++) . get) implicit_main decls
 
-       -- Virtually every program has error messages in it somewhere
-    string_occs = [unpackCString_RDR, unpackCStringFoldr_RDR, 
-                  unpackCStringUtf8_RDR, eqString_RDR]
 
     get (TyClD (TyData _ _ _ _ _ _ (Just deriv_classes) _ _ _))
        = concat (map get_deriv deriv_classes)
@@ -308,6 +321,10 @@ implicitFVs mod_name decls
     get_deriv cls = case lookupUFM derivingOccurrences cls of
                        Nothing   -> []
                        Just occs -> occs
+
+-- Virtually every program has error messages in it somewhere
+string_occs = [unpackCString_RDR, unpackCStringFoldr_RDR, 
+              unpackCStringUtf8_RDR, eqString_RDR]
 \end{code}
 
 \begin{code}

diff --git a/ghc/compiler/rename/RnHiFiles.lhs b/ghc/compiler/rename/RnHiFiles.lhs
index 84403d7..9e6a926 100644 (file)
--- a/ghc/compiler/rename/RnHiFiles.lhs
+++ b/ghc/compiler/rename/RnHiFiles.lhs
@@ -107,7 +107,7 @@ tryLoadInterface :: SDoc -> ModuleName -> WhereFrom -> RnM d (ModIface, Maybe Me
 tryLoadInterface doc_str mod_name from
  = getHomeIfaceTableRn         `thenRn` \ hit ->
    getIfacesRn                         `thenRn` \ ifaces@(Ifaces { iPIT = pit }) ->
-       
+
        -- CHECK WHETHER WE HAVE IT ALREADY
    case lookupIfaceByModName hit pit mod_name of {
        Just iface |  case from of

diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs
index e75d88d..dca4edb 100644 (file)
--- a/ghc/compiler/stgSyn/CoreToStg.lhs
+++ b/ghc/compiler/stgSyn/CoreToStg.lhs
@@ -39,8 +39,8 @@ import Type           ( isUnLiftedType, isUnboxedTupleType, Type, splitFunTy_maybe,
 import UniqSupply      -- all of it, really
 import BasicTypes      ( TopLevelFlag(..), isNotTopLevel )
 import UniqSet         ( emptyUniqSet )
-import ErrUtils                ( showPass )
-import CmdLineOpts     ( DynFlags )
+import ErrUtils                ( showPass, dumpIfSet_dyn )
+import CmdLineOpts     ( DynFlags, DynFlag(..) )
 import Maybes
 import Outputable
 \end{code}
@@ -220,7 +220,9 @@ coreToStgExpr :: DynFlags -> CoreExpr -> IO StgExpr
 coreToStgExpr dflags core_expr
   = do showPass dflags "Core2Stg"
        us <- mkSplitUniqSupply 'c'
-       return (initUs_ us (coreExprToStg emptyVarEnv core_expr))
+       let stg_expr = initUs_ us (coreExprToStg emptyVarEnv core_expr)
+       dumpIfSet_dyn dflags Opt_D_dump_stg "STG syntax:" (ppr stg_expr)
+       return stg_expr
 \end{code}
 
 %************************************************************************