[project @ 2003-02-19 13:05:45 by simonpj]

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

diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs
index 9ca6819..d360dd9 100644 (file)
--- a/ghc/compiler/main/HscMain.lhs
+++ b/ghc/compiler/main/HscMain.lhs
@@ -28,6 +28,8 @@ import RdrHsSyn               ( RdrNameStmt )
 import Type            ( Type )
 import PrelNames       ( iNTERACTIVE )
 import StringBuffer    ( stringToStringBuffer )
+import Name            ( Name )
+import CoreLint                ( lintUnfolding )
 #endif
 
 import HsSyn
@@ -38,10 +40,11 @@ import IdInfo               ( CafInfo(..), CgInfoEnv, CgInfo(..) )
 import StringBuffer    ( hGetStringBuffer, freeStringBuffer )
 import Parser
 import Lex             ( ParseResult(..), ExtFlags(..), mkPState )
-import SrcLoc          ( mkSrcLoc )
+import SrcLoc          ( mkSrcLoc, noSrcLoc )
 import TcRnDriver      ( checkOldIface, tcRnModule, tcRnExtCore, tcRnIface )
+import RnEnv           ( extendOrigNameCache )
 import Rules           ( emptyRuleBase )
-import PrelInfo                ( wiredInThingEnv, wiredInThings, knownKeyNames )
+import PrelInfo                ( wiredInThingEnv, knownKeyNames )
 import PrelRules       ( builtinRules )
 import MkIface         ( mkIface )
 import InstEnv         ( emptyInstEnv )
@@ -57,7 +60,7 @@ import SimplStg               ( stg2stg )
 import CodeGen         ( codeGen )
 import CodeOutput      ( codeOutput )
 
-import Module          ( ModuleName, moduleName )
+import Module          ( emptyModuleEnv )
 import CmdLineOpts
 import DriverPhases     ( isExtCore_file )
 import ErrUtils                ( dumpIfSet_dyn, showPass, printError )
@@ -70,9 +73,8 @@ import HscTypes
 import MkExternalCore  ( emitExternalCore )
 import ParserCore
 import ParserCoreUtils
-import FiniteMap       ( FiniteMap, plusFM, emptyFM, addToFM )
-import OccName         ( OccName )
-import Name            ( Name, nameModule, nameOccName, getName )
+import FiniteMap       ( emptyFM )
+import Name            ( nameModule, getName )
 import NameEnv         ( emptyNameEnv, mkNameEnv )
 import NameSet         ( emptyNameSet )
 import Module          ( Module, ModLocation(..), showModMsg )
@@ -329,7 +331,7 @@ hscFrontEnd hsc_env pcs_ch location = do {
            -- PARSE
            -------------------
        ; maybe_parsed <- myParseModule (hsc_dflags hsc_env) 
-                             (expectJust "hscRecomp:hspp" (ml_hspp_file location))
+                             (expectJust "hscFrontEnd:hspp" (ml_hspp_file location))
 
        ; case maybe_parsed of {
             Nothing -> return (Left (HscFail pcs_ch));
@@ -343,7 +345,7 @@ hscFrontEnd hsc_env pcs_ch location = do {
        ; case maybe_tc_result of {
             Nothing -> return (Left (HscFail pcs_ch));
             Just tc_result -> do {
-    
+
            -------------------
            -- DESUGAR
            -------------------
@@ -392,8 +394,7 @@ hscBackEnd dflags cg_info_ref prepd_result
                          
            ------------------  Code output -----------------------
            (stub_h_exists, stub_c_exists)
-                    <- codeOutput dflags prepd_result
-                                  stg_binds abstractC
+                    <- codeOutput dflags prepd_result abstractC
                              
            return (stub_h_exists, stub_c_exists, Nothing)
 
@@ -513,7 +514,9 @@ hscStmt hsc_env pcs icontext stmt
 
                -- Then desugar, code gen, and link it
        ; hval <- compileExpr hsc_env pcs1 iNTERACTIVE 
-                             (icPrintUnqual new_ic) tc_expr
+                             (ic_rn_gbl_env new_ic) 
+                             (ic_type_env new_ic)
+                             tc_expr
 
        ; return (pcs1, Just (new_ic, bound_names, hval))
        }}}}}
@@ -631,15 +634,16 @@ myParseIdentifier dflags str
 #ifdef GHCI
 compileExpr :: HscEnv 
            -> PersistentCompilerState
-           -> Module -> PrintUnqualified
+           -> Module -> GlobalRdrEnv -> TypeEnv
            -> TypecheckedHsExpr
            -> IO HValue
 
-compileExpr hsc_env pcs this_mod print_unqual tc_expr
-  = do { let dflags = hsc_dflags hsc_env
-
+compileExpr hsc_env pcs this_mod rdr_env type_env tc_expr
+  = do { let { dflags  = hsc_dflags hsc_env ;
+               lint_on = dopt Opt_DoCoreLinting dflags }
+             
                -- Desugar it
-       ; ds_expr <- deSugarExpr hsc_env pcs this_mod print_unqual tc_expr
+       ; ds_expr <- deSugarExpr hsc_env pcs this_mod rdr_env type_env tc_expr
        
                -- Flatten it
        ; flat_expr <- flattenExpr hsc_env pcs ds_expr
@@ -653,6 +657,15 @@ compileExpr hsc_env pcs this_mod print_unqual tc_expr
                -- Prepare for codegen
        ; prepd_expr <- corePrepExpr dflags tidy_expr
 
+               -- Lint if necessary
+               -- ToDo: improve SrcLoc
+       ; if lint_on then 
+               case lintUnfolding noSrcLoc [] prepd_expr of
+                  Just err -> pprPanic "compileExpr" err
+                  Nothing  -> return ()
+         else
+               return ()
+
                -- Convert to BCOs
        ; bcos <- coreExprToBCOs dflags prepd_expr
 
@@ -692,7 +705,6 @@ initExternalPackageState
       eps_insts      = (emptyBag, 0),
       eps_inst_gates = emptyNameSet,
       eps_rules      = foldr add_rule (emptyBag, 0) builtinRules,
-      eps_imp_mods   = emptyFM,
 
       eps_PIT       = emptyPackageIfaceTable,
       eps_PTE       = wiredInThingEnv,
@@ -705,14 +717,10 @@ initExternalPackageState
        where
           gated_decl = (gate_fn, (mod, IfaceRuleOut rdr_name rule))
           mod        = nameModule name
-          rdr_name   = nameRdrName name
-          gate_fn vis_fn = vis_fn name -- Load the rule whenever name is visible
-
-initOrigNames :: FiniteMap (ModuleName,OccName) Name
-initOrigNames 
-   = grab knownKeyNames `plusFM` grab (map getName wiredInThings)
-     where
-        grab names = foldl add emptyFM names
-        add env name 
-           = addToFM env (moduleName (nameModule name), nameOccName name) name
+          rdr_name   = nameRdrName name        -- Seems a bit of a hack to go back
+                                               -- to the RdrName
+          gate_fn vis_fn = vis_fn name         -- Load the rule whenever name is visible
+
+initOrigNames :: OrigNameCache
+initOrigNames = foldl extendOrigNameCache emptyModuleEnv knownKeyNames 
 \end{code}