[project @ 2003-02-05 11:39:26 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 49f4a2f..336e2ce 100644 (file)
--- a/ghc/compiler/main/HscMain.lhs
+++ b/ghc/compiler/main/HscMain.lhs
@@ -29,6 +29,7 @@ import Type           ( Type )
 import PrelNames       ( iNTERACTIVE )
 import StringBuffer    ( stringToStringBuffer )
 import Name            ( Name )
+import CoreLint                ( lintUnfolding )
 #endif
 
 import HsSyn
@@ -39,7 +40,7 @@ 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 )
@@ -330,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));
@@ -344,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
            -------------------
@@ -393,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)
 
@@ -514,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))
        }}}}}
@@ -632,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
@@ -654,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
 
@@ -705,8 +717,9 @@ 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
+          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