From: simonmar Date: Tue, 21 Nov 2000 16:43:26 +0000 (+0000) Subject: [project @ 2000-11-21 16:42:58 by simonmar] X-Git-Tag: Approximately_9120_patches~3274 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=bd8f046eba3639399af46d3393752ed5905fb1e9;p=ghc-hetmet.git [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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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} %************************************************************************