[project @ 2001-11-23 11:47:37 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 f1a57b6..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,10 +30,12 @@ import HscTypes             ( InteractiveContext(..) )
 import PrelNames       ( iNTERACTIVE )
 import StringBuffer    ( stringToStringBuffer )
 import FastString       ( mkFastString )
+import Maybes          ( catMaybes )
 #endif
 
 import HsSyn
 
+import RdrName         ( mkRdrOrig )
 import Id              ( idName )
 import IdInfo          ( CafInfo(..), CgInfoEnv, CgInfo(..) )
 import StringBuffer    ( hGetStringBuffer, freeStringBuffer )
@@ -43,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
@@ -65,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 )
@@ -79,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 )
@@ -158,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)
       }
@@ -187,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)
@@ -203,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);
 
@@ -431,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}
 
 
@@ -694,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