[project @ 2001-11-08 12:50:07 by simonmar]

[ghc-hetmet.git] / ghc / compiler / main / HscMain.lhs

diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs
index 2e38352..b5085cd 100644 (file)
--- a/ghc/compiler/main/HscMain.lhs
+++ b/ghc/compiler/main/HscMain.lhs
@@ -14,6 +14,7 @@ module HscMain ( HscResult(..), hscMain,
 #include "HsVersions.h"
 
 #ifdef GHCI
+import Interpreter
 import ByteCodeGen     ( byteCodeGen )
 import CoreTidy                ( tidyCoreExpr )
 import CorePrep                ( corePrepExpr )
@@ -29,12 +30,12 @@ import HscTypes             ( InteractiveContext(..) )
 import PrelNames       ( iNTERACTIVE )
 import StringBuffer    ( stringToStringBuffer )
 import FastString       ( mkFastString )
-import Char            ( isUpper )
-import DriverUtil      ( split_longest_prefix )
+import Maybes          ( catMaybes )
 #endif
 
 import HsSyn
 
+import RdrName         ( mkRdrOrig )
 import Id              ( idName )
 import IdInfo          ( CafInfo(..), CgInfoEnv, CgInfo(..) )
 import StringBuffer    ( hGetStringBuffer, freeStringBuffer )
@@ -45,6 +46,7 @@ import Finder         ( findModule )
 import Rename          ( checkOldIface, renameModule, closeIfaceDecls )
 import Rules           ( emptyRuleBase )
 import PrelInfo                ( wiredInThingEnv, wiredInThings )
+import PrelRules       ( builtinRules )
 import PrelNames       ( knownKeyNames )
 import MkIface         ( mkFinalIface )
 import TcModule
@@ -67,9 +69,8 @@ import ErrUtils               ( dumpIfSet_dyn, showPass, printError )
 import Util            ( unJust )
 import UniqSupply      ( mkSplitUniqSupply )
 
-import Bag             ( emptyBag )
+import Bag             ( consBag, emptyBag )
 import Outputable
-import Interpreter
 import HscStats                ( ppSourceStats )
 import HscTypes
 import FiniteMap       ( FiniteMap, plusFM, emptyFM, addToFM )
@@ -81,7 +82,7 @@ import Module         ( Module )
 import IOExts          ( newIORef, readIORef, writeIORef, unsafePerformIO )
 
 import Monad           ( when )
-import Maybe           ( isJust, fromJust, catMaybes )
+import Maybe           ( isJust, fromJust )
 import IO
 
 import MkExternalCore  ( emitExternalCore )
@@ -160,7 +161,8 @@ hscNoRecomp ghci_mode dflags have_object
            mod location (Just old_iface) hst hit pcs_ch
  | ghci_mode == OneShot
  = do {
-      hPutStrLn stderr "compilation IS NOT required";
+      when (verbosity dflags > 0) $
+         hPutStrLn stderr "compilation IS NOT required";
       let { bomb = panic "hscNoRecomp:OneShot" };
       return (HscNoRecomp pcs_ch bomb bomb)
       }
@@ -189,7 +191,7 @@ hscNoRecomp ghci_mode dflags have_object
       }}}
 
 compMsg use_object mod location =
-    mod_str ++ take (max 0 (16 - length mod_str)) (repeat ' ')
+    mod_str ++ replicate (max 0 (16 - length mod_str)) ' '
     ++" ( " ++ unJust "hscRecomp" (ml_hs_file location) ++ ", "
     ++ (if use_object
          then unJust "hscRecomp" (ml_obj_file location)
@@ -205,7 +207,7 @@ hscRecomp ghci_mode dflags have_object
        ; let toInterp = dopt_HscLang dflags == HscInterpreted
        ; let toNothing = dopt_HscLang dflags == HscNothing
 
-       ; when (verbosity dflags >= 1) $
+       ; when (ghci_mode /= OneShot && verbosity dflags >= 1) $
                hPutStrLn stderr ("Compiling " ++ 
                        compMsg (not toInterp) mod location);
 
@@ -433,19 +435,14 @@ myCoreToStg dflags this_mod tidy_binds
           <- _scc_ "Core2Stg" stg2stg dflags this_mod stg_binds
 
       let env_rhs :: CgInfoEnv
-         env_rhs = mkNameEnv [ (idName bndr, CgInfo (stgRhsArity rhs) caf_info)
+         env_rhs = mkNameEnv [ (idName bndr, CgInfo caf_info)
                              | (bind,_) <- stg_binds2, 
                                let caf_info 
                                     | stgBindHasCafRefs bind = MayHaveCafRefs
-                                    | otherwise = NoCafRefs,
-                               (bndr,rhs) <- stgBindPairs bind ]
+                                    | otherwise              = NoCafRefs,
+                               bndr <- stgBinders bind ]
 
       return (stg_binds2, cost_centre_info, env_rhs)
-   where
-      stgBindPairs (StgNonRec _ b r) = [(b,r)]
-      stgBindPairs (StgRec    _ prs) = prs
-
-
 \end{code}
 
 
@@ -499,13 +496,7 @@ A naked expression returns a singleton Name [it].
 
 \begin{code}
 hscStmt dflags hst hit pcs0 icontext stmt just_expr
-   = let 
-       InteractiveContext { 
-            ic_rn_env   = rn_env, 
-            ic_type_env = type_env,
-            ic_module   = scope_mod } = icontext
-     in
-     do { maybe_stmt <- hscParseStmt dflags stmt
+   =  do { maybe_stmt <- hscParseStmt dflags stmt
        ; case maybe_stmt of
             Nothing -> return (pcs0, Nothing)
             Just parsed_stmt -> do {
@@ -521,8 +512,8 @@ hscStmt dflags hst hit pcs0 icontext stmt just_expr
 
                -- Rename it
          (pcs1, print_unqual, maybe_renamed_stmt)
-                <- renameStmt dflags hit hst pcs0 scope_mod 
-                               iNTERACTIVE rn_env parsed_stmt
+                <- renameStmt dflags hit hst pcs0 
+                       iNTERACTIVE icontext parsed_stmt
 
        ; case maybe_renamed_stmt of
                Nothing -> return (pcs0, Nothing)
@@ -532,9 +523,9 @@ hscStmt dflags hst hit pcs0 icontext stmt just_expr
          maybe_tc_return <- 
            if just_expr 
                then case rn_stmt of { (ExprStmt e _ _, decls) -> 
-                    typecheckExpr dflags pcs1 hst type_env
+                    typecheckExpr dflags pcs1 hst (ic_type_env icontext)
                           print_unqual iNTERACTIVE (e,decls) }
-               else typecheckStmt dflags pcs1 hst type_env
+               else typecheckStmt dflags pcs1 hst (ic_type_env icontext)
                           print_unqual iNTERACTIVE bound_names rn_stmt
 
        ; case maybe_tc_return of
@@ -621,12 +612,7 @@ hscThing -- like hscStmt, but deals with a single identifier
          [TyThing] )
 
 hscThing dflags hst hit pcs0 icontext str
-   = do let 
-         InteractiveContext {
-            ic_rn_env   = rn_env,
-            ic_module   = scope_mod } = icontext
-
-       maybe_rdr_name <- myParseIdentifier dflags str
+   = do maybe_rdr_name <- myParseIdentifier dflags str
        case maybe_rdr_name of {
          Nothing -> return (pcs0, []);
          Just rdr_name -> do
@@ -643,8 +629,7 @@ hscThing dflags hst hit pcs0 icontext str
                tccls_name = setRdrNameOcc rdr_name tccls_occ
 
        (pcs, unqual, maybe_rn_result) <- 
-          renameRdrName dflags hit hst pcs0 scope_mod scope_mod 
-               rn_env rdr_names
+          renameRdrName dflags hit hst pcs0 iNTERACTIVE icontext rdr_names
 
        case maybe_rn_result of {
             Nothing -> return (pcs, []);
@@ -708,10 +693,18 @@ initPersistentRenamerState :: IO PersistentRenamerState
                                      nsIPs   = emptyFM },
              prsDecls   = (emptyNameEnv, 0),
              prsInsts   = (emptyBag, 0),
-             prsRules   = (emptyBag, 0),
+             prsRules   = foldr add_rule (emptyBag, 0) builtinRules,
              prsImpMods = emptyFM
             }
         )
+  where
+    add_rule (name,rule) (rules, n_rules)
+        = (gated_decl `consBag` rules, n_rules+1)
+       where
+          gated_decl = (gate_fn, (mod, IfaceRuleOut rdr_name rule))
+          mod        = nameModule name
+          rdr_name   = mkRdrOrig (moduleName mod) (nameOccName name)
+          gate_fn vis_fn = vis_fn name -- Load the rule whenever name is visible
 
 initOrigNames :: FiniteMap (ModuleName,OccName) Name
 initOrigNames