[project @ 2001-01-25 17:47:12 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 377e2e5..a49bf45 100644 (file)
--- a/ghc/compiler/main/HscMain.lhs
+++ b/ghc/compiler/main/HscMain.lhs
@@ -197,7 +197,8 @@ hscRecomp ghci_mode dflags location maybe_checked_iface hst hit pcs_ch
            -- RENAME
            -------------------
        ; (pcs_rn, maybe_rn_result) 
-            <- renameModule dflags hit hst pcs_ch this_mod rdr_module
+            <- _scc_ "Rename" 
+                renameModule dflags hit hst pcs_ch this_mod rdr_module
        ; case maybe_rn_result of {
             Nothing -> return (HscFail pcs_rn);
             Just (print_unqualified, (is_exported, new_iface, rn_hs_decls)) -> do {
@@ -205,7 +206,8 @@ hscRecomp ghci_mode dflags location maybe_checked_iface hst hit pcs_ch
            -------------------
            -- TYPECHECK
            -------------------
-       ; maybe_tc_result <- typecheckModule dflags pcs_rn hst new_iface 
+       ; maybe_tc_result 
+           <- _scc_ "TypeCheck" typecheckModule dflags pcs_rn hst new_iface 
                                             print_unqualified rn_hs_decls
        ; case maybe_tc_result of {
             Nothing -> return (HscFail pcs_rn);
@@ -217,7 +219,8 @@ hscRecomp ghci_mode dflags location maybe_checked_iface hst hit pcs_ch
            -- DESUGAR
            -------------------
        ; (ds_binds, ds_rules, foreign_stuff) 
-             <- deSugar dflags pcs_tc hst this_mod print_unqualified tc_result
+             <- _scc_ "DeSugar" 
+               deSugar dflags pcs_tc hst this_mod print_unqualified tc_result
 
            -------------------
            -- SIMPLIFY, TIDY-CORE
@@ -230,7 +233,8 @@ hscRecomp ghci_mode dflags location maybe_checked_iface hst hit pcs_ch
            -- BUILD THE NEW ModDetails AND ModIface
            -------------------
        ; let new_details = mkModDetails env_tc tidy_binds orphan_rules
-       ; final_iface <- mkFinalIface ghci_mode dflags location 
+       ; final_iface <- _scc_ "MkFinalIface" 
+                         mkFinalIface ghci_mode dflags location 
                                       maybe_checked_iface new_iface new_details
 
            -------------------
@@ -273,7 +277,7 @@ mkFinalIface ghci_mode dflags location maybe_old_iface new_iface new_details
 myParseModule dflags src_filename
  = do --------------------------  Parser  ----------------
       showPass dflags "Parser"
-      -- _scc_     "Parser"
+      _scc_  "Parser" do
 
       buf <- hGetStringBuffer True{-expand tabs-} src_filename
 
@@ -327,16 +331,16 @@ restOfCodeGeneration dflags toInterp this_mod imported_module_names
  = do
       --------------------------  Convert to STG -------------------------------
       (stg_binds, cost_centre_info) 
-               <- myCoreToStg dflags this_mod tidy_binds env_tc
+               <- _scc_ "CoreToStg"
+                   myCoreToStg dflags this_mod tidy_binds env_tc
 
-      --------------------------  Code generation -------------------------------
-      -- _scc_     "CodeGen"
-      abstractC <- codeGen dflags this_mod imported_modules
+      --------------------------  Code generation ------------------------------
+      abstractC <- _scc_ "CodeGen"
+                   codeGen dflags this_mod imported_modules
                            cost_centre_info fe_binders
                            local_tycons stg_binds
 
       --------------------------  Code output -------------------------------
-      -- _scc_     "CodeOutput"
       (maybe_stub_h_name, maybe_stub_c_name)
          <- codeOutput dflags this_mod local_tycons
                        tidy_binds stg_binds
@@ -370,11 +374,11 @@ myCoreToStg dflags this_mod tidy_binds env_tc
 
       --let bcos = byteCodeGen dflags tidy_binds local_tycons local_classes
 
-      -- _scc_     "Core2Stg"
-      stg_binds <- coreToStg dflags this_mod tidy_binds
+      
+      stg_binds <- _scc_ "Core2Stg" coreToStg dflags this_mod tidy_binds
 
-      -- _scc_     "Stg2Stg"
-      (stg_binds2, cost_centre_info) <- stg2stg dflags this_mod stg_binds
+      (stg_binds2, cost_centre_info)
+          <- _scc_ "Core2Stg" stg2stg dflags this_mod stg_binds
 
       return (stg_binds2, cost_centre_info)
    where
@@ -393,16 +397,16 @@ myCoreToStg dflags this_mod tidy_binds env_tc
 #ifdef GHCI
 hscExpr
   :: DynFlags
+  -> Bool                      -- True <=> wrap in 'print' to get a result of IO type
   -> HomeSymbolTable   
   -> HomeIfaceTable
   -> PersistentCompilerState    -- IN: persistent compiler state
   -> Module                    -- Context for compiling
   -> String                    -- The expression
-  -> Bool                      -- Should we wrap print if not IO-typed?
   -> IO ( PersistentCompilerState, 
          Maybe (UnlinkedBCOExpr, PrintUnqualified, Type) )
 
-hscExpr dflags hst hit pcs0 this_module expr wrap_print
+hscExpr dflags wrap_io hst hit pcs0 this_module expr
    = do {
        maybe_parsed <- hscParseExpr dflags expr;
        case maybe_parsed of
@@ -418,28 +422,11 @@ hscExpr dflags hst hit pcs0 this_module expr wrap_print
 
                -- Typecheck it
        maybe_tc_return
-          <- typecheckExpr dflags pcs1 hst print_unqual this_module rn_expr;
+          <- typecheckExpr dflags wrap_io pcs1 hst print_unqual this_module rn_expr;
        case maybe_tc_return of {
                Nothing -> return ({-WAS:pcs1-} pcs0, Nothing);
                Just (pcs2, tc_expr, ty) -> do
 
-       -- if it isn't an IO-typed expression, 
-       -- wrap "print" around it & recompile...
-       let { is_IO_type = case splitTyConApp_maybe ty of {
-                           Just (tycon, _) -> getUnique tycon == ioTyConKey;
-                           Nothing -> False }
-            };
-
-        if (wrap_print && not is_IO_type)
-               then do (new_pcs, maybe_stuff)
-                         <- hscExpr dflags hst hit pcs2 this_module
-                               ("PrelIO.print (" ++ expr ++ ")") False
-                       case maybe_stuff of
-                          Nothing -> return (new_pcs, maybe_stuff)
-                          Just (bcos, _, _) ->
-                             return (new_pcs, Just (bcos, print_unqual, ty))
-               else do
-
                -- Desugar it
        ds_expr <- deSugarExpr dflags pcs2 hst this_module
                        print_unqual tc_expr;
@@ -462,7 +449,7 @@ hscParseExpr :: DynFlags -> String -> IO (Maybe RdrNameHsExpr)
 hscParseExpr dflags str
  = do --------------------------  Parser  ----------------
       showPass dflags "Parser"
-      -- _scc_     "Parser"
+      _scc_ "Parser" do
 
       buf <- stringToStringBuffer str