[project @ 2001-01-19 15:26:37 by simonmar]
[ghc-hetmet.git] / ghc / compiler / main / HscMain.lhs
index d6ae43c..21da9dc 100644 (file)
@@ -5,39 +5,48 @@
 
 \begin{code}
 module HscMain ( HscResult(..), hscMain, 
+#ifdef GHCI
+                hscExpr,
+#endif
                 initPersistentCompilerState ) where
 
 #include "HsVersions.h"
 
-import Maybe           ( isJust )
-import IO              ( hPutStrLn, stderr )
+#ifdef GHCI
+import RdrHsSyn                ( RdrNameHsExpr )
+import Rename          ( renameExpr )
+import StringBuffer    ( stringToStringBuffer, freeStringBuffer )
+import Unique          ( Uniquable(..) )
+import Type            ( Type, splitTyConApp_maybe )
+import PrelNames       ( ioTyConKey )
+import ByteCodeGen     ( byteCodeGen )
+#endif
+
 import HsSyn
 
 import StringBuffer    ( hGetStringBuffer )
-import Parser          ( parse )
+import Parser
 import Lex             ( PState(..), ParseResult(..) )
 import SrcLoc          ( mkSrcLoc )
-
-import Rename          ( renameModule, checkOldIface, closeIfaceDecls )
+import Rename          ( checkOldIface, renameModule, closeIfaceDecls )
 import Rules           ( emptyRuleBase )
 import PrelInfo                ( wiredInThingEnv, wiredInThings )
 import PrelNames       ( knownKeyNames )
 import MkIface         ( completeIface, mkModDetailsFromIface, mkModDetails,
                          writeIface, pprIface )
-import TcModule                ( TcResults(..), typecheckModule )
+import TcModule
 import InstEnv         ( emptyInstEnv )
-import Desugar         ( deSugar )
-import SimplCore       ( core2core )
-import OccurAnal       ( occurAnalyseBinds )
+import Desugar
+import SimplCore
 import CoreUtils       ( coreBindsSize )
 import CoreTidy                ( tidyCorePgm )
-import CoreToStg       ( topCoreBindsToStg )
-import StgSyn          ( collectFinalStgBinders )
+import CoreSat
+import CoreToStg       ( coreToStg )
 import SimplStg                ( stg2stg )
 import CodeGen         ( codeGen )
 import CodeOutput      ( codeOutput )
 
-import Module          ( ModuleName, moduleName, mkModuleInThisPackage )
+import Module          ( ModuleName, moduleName, mkHomeModule )
 import CmdLineOpts
 import ErrUtils                ( dumpIfSet_dyn, showPass )
 import Util            ( unJust )
@@ -45,12 +54,13 @@ import UniqSupply   ( mkSplitUniqSupply )
 
 import Bag             ( emptyBag )
 import Outputable
-import Interpreter     ( UnlinkedIBind, ItblEnv, stgToInterpSyn )
+import Interpreter
+import CmStaticInfo    ( GhciMode(..) )
 import HscStats                ( ppSourceStats )
 import HscTypes                ( ModDetails, ModIface(..), PersistentCompilerState(..),
                          PersistentRenamerState(..), ModuleLocation(..),
                          HomeSymbolTable, 
-                         OrigNameEnv(..), PackageRuleBase, HomeIfaceTable, 
+                         NameSupply(..), PackageRuleBase, HomeIfaceTable, 
                          typeEnvClasses, typeEnvTyCons, emptyIfaceTable )
 import FiniteMap       ( FiniteMap, plusFM, emptyFM, addToFM )
 import OccName         ( OccName )
@@ -59,6 +69,8 @@ import Name           ( emptyNameEnv )
 import Module          ( Module, lookupModuleEnvByName )
 
 import Monad           ( when )
+import Maybe           ( isJust )
+import IO
 \end{code}
 
 
@@ -70,19 +82,27 @@ import Monad                ( when )
 
 \begin{code}
 data HscResult
-   = HscOK   ModDetails             -- new details (HomeSymbolTable additions)
-            (Maybe ModIface)        -- new iface (if any compilation was done)
-            (Maybe String)          -- generated stub_h filename (in /tmp)
-            (Maybe String)          -- generated stub_c filename (in /tmp)
-            (Maybe ([UnlinkedIBind],ItblEnv)) -- interpreted code, if any
-             PersistentCompilerState -- updated PCS
-
-   | HscFail PersistentCompilerState -- updated PCS
+   -- compilation failed
+   = HscFail     PersistentCompilerState -- updated PCS
+   -- concluded that it wasn't necessary
+   | HscNoRecomp PersistentCompilerState -- updated PCS
+                 ModDetails             -- new details (HomeSymbolTable additions)
+                ModIface                -- new iface (if any compilation was done)
+   -- did recompilation
+   | HscRecomp   PersistentCompilerState -- updated PCS
+                 ModDetails             -- new details (HomeSymbolTable additions)
+                 ModIface               -- new iface (if any compilation was done)
+                (Maybe String)          -- generated stub_h filename (in /tmp)
+                (Maybe String)          -- generated stub_c filename (in /tmp)
+                (Maybe ([UnlinkedBCO],ItblEnv)) -- interpreted code, if any
+             
+
        -- no errors or warnings; the individual passes
        -- (parse/rename/typecheck) print messages themselves
 
 hscMain
-  :: DynFlags
+  :: GhciMode
+  -> DynFlags
   -> Bool                      -- source unchanged?
   -> ModuleLocation            -- location info
   -> Maybe ModIface            -- old interface, if available
@@ -91,14 +111,16 @@ hscMain
   -> PersistentCompilerState    -- IN: persistent compiler state
   -> IO HscResult
 
-hscMain dflags source_unchanged location maybe_old_iface hst hit pcs
+hscMain ghci_mode dflags source_unchanged location maybe_old_iface hst hit pcs
  = do {
-      putStrLn ("CHECKING OLD IFACE for hs = " ++ show (ml_hs_file location)
-                ++ ", hspp = " ++ show (ml_hspp_file location));
+      showPass dflags ("Checking old interface for hs = " 
+                       ++ show (ml_hs_file location)
+                       ++ ", hspp = " ++ show (ml_hspp_file location));
 
       (pcs_ch, errs_found, (recomp_reqd, maybe_checked_iface))
-         <- checkOldIface dflags hit hst pcs (unJust (ml_hi_file location) "hscMain")
-                         source_unchanged maybe_old_iface;
+         <- checkOldIface ghci_mode dflags hit hst pcs 
+               (unJust "hscMain" (ml_hi_file location))
+               source_unchanged maybe_old_iface;
 
       if errs_found then
          return (HscFail pcs_ch)
@@ -108,20 +130,24 @@ hscMain dflags source_unchanged location maybe_old_iface hst hit pcs
           what_next | recomp_reqd || no_old_iface = hscRecomp 
                     | otherwise                   = hscNoRecomp
       ;
-      what_next dflags location maybe_checked_iface
+      what_next ghci_mode dflags location maybe_checked_iface
                 hst hit pcs_ch
       }}
 
 
-hscNoRecomp dflags location maybe_checked_iface hst hit pcs_ch
+-- we definitely expect to have the old interface available
+hscNoRecomp ghci_mode dflags location (Just old_iface) hst hit pcs_ch
+ | ghci_mode == OneShot
  = do {
-      hPutStrLn stderr "COMPILATION NOT REQUIRED";
-      -- we definitely expect to have the old interface available
-      let old_iface = case maybe_checked_iface of 
-                         Just old_if -> old_if
-                         Nothing -> panic "hscNoRecomp:old_iface"
-          this_mod = mi_module old_iface
-      ;
+      hPutStrLn stderr "compilation IS NOT required";
+      let { bomb = panic "hscNoRecomp:OneShot" };
+      return (HscNoRecomp pcs_ch bomb bomb)
+      }
+ | otherwise
+ = do {
+      hPutStr stderr "compilation IS NOT required";
+      when (verbosity dflags /= 1) $ hPutStrLn stderr "";
+
       -- CLOSURE
       (pcs_cl, closure_errs, cl_hs_decls) 
          <- closeIfaceDecls dflags hit hst pcs_ch old_iface ;
@@ -130,31 +156,29 @@ hscNoRecomp dflags location maybe_checked_iface hst hit pcs_ch
       else do {
 
       -- TYPECHECK
-      maybe_tc_result <- typecheckModule dflags this_mod pcs_cl hst 
+      maybe_tc_result <- typecheckModule dflags pcs_cl hst 
                                         old_iface alwaysQualify cl_hs_decls;
       case maybe_tc_result of {
          Nothing -> return (HscFail pcs_cl);
-         Just tc_result -> do {
+         Just (pcs_tc, tc_result) -> do {
 
-      let pcs_tc      = tc_pcs tc_result
-          env_tc      = tc_env tc_result
-          local_insts = tc_insts tc_result
+      let env_tc      = tc_env tc_result
           local_rules = tc_rules tc_result
       ;
       -- create a new details from the closed, typechecked, old iface
-      let new_details = mkModDetailsFromIface env_tc local_insts local_rules
+      let new_details = mkModDetailsFromIface env_tc local_rules
       ;
-      return (HscOK new_details
-                   Nothing -- tells CM to use old iface and linkables
-                   Nothing Nothing -- foreign export stuff
-                    Nothing -- ibinds
-                   pcs_tc)
+      return (HscNoRecomp pcs_tc new_details old_iface)
       }}}}
 
 
-hscRecomp dflags location maybe_checked_iface hst hit pcs_ch
+hscRecomp ghci_mode dflags location maybe_checked_iface hst hit pcs_ch
  = do  {
-       ; hPutStrLn stderr "COMPILATION IS REQUIRED";
+       ; when (verbosity dflags >= 1) $
+               hPutStr stderr "compilation IS required";
+         -- mode -v1 tries to keep everything on one line
+         when (verbosity dflags > 1) $
+               hPutStrLn stderr "";
 
          -- what target are we shooting for?
        ; let toInterp = dopt_HscLang dflags == HscInterpreted
@@ -162,76 +186,75 @@ hscRecomp dflags location maybe_checked_iface hst hit pcs_ch
            -------------------
            -- PARSE
            -------------------
-       ; maybe_parsed <- myParseModule dflags (unJust (ml_hspp_file location) "hscRecomp:hspp")
+       ; maybe_parsed <- myParseModule dflags 
+                             (unJust "hscRecomp:hspp" (ml_hspp_file location))
        ; case maybe_parsed of {
             Nothing -> return (HscFail pcs_ch);
             Just rdr_module -> do {
-       ; let this_mod = mkModuleInThisPackage (hsModuleName rdr_module)
+       ; let this_mod = mkHomeModule (hsModuleName rdr_module)
     
            -------------------
            -- 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 {
+            Just (print_unqualified, (is_exported, new_iface, rn_hs_decls)) -> do {
     
            -------------------
            -- TYPECHECK
            -------------------
-       ; maybe_tc_result <- typecheckModule dflags this_mod 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 -> do { hPutStrLn stderr "Typecheck failed" 
-                          ; return (HscFail pcs_rn) } ;
-            Just tc_result -> do {
+            Nothing -> return (HscFail pcs_rn);
+            Just (pcs_tc, tc_result) -> do {
     
-       ; let pcs_tc        = tc_pcs tc_result
-             env_tc        = tc_env tc_result
-             local_insts   = tc_insts tc_result
+       ; let env_tc = tc_env tc_result
 
            -------------------
-           -- DESUGAR, SIMPLIFY, TIDY-CORE
+           -- DESUGAR
            -------------------
-         -- We grab the the unfoldings at this point.
-       ; simpl_result <- dsThenSimplThenTidy dflags (pcs_rules pcs_tc) this_mod 
-                                             print_unqualified is_exported tc_result hst
-       ; let (tidy_binds, orphan_rules, foreign_stuff) = simpl_result
-           
+       ; (ds_binds, ds_rules, foreign_stuff) 
+             <- _scc_ "DeSugar" 
+               deSugar dflags pcs_tc hst this_mod print_unqualified tc_result
+
            -------------------
-           -- CONVERT TO STG
+           -- SIMPLIFY, TIDY-CORE
            -------------------
-       ; (stg_binds, oa_tidy_binds, cost_centre_info, top_level_ids) 
-            <- myCoreToStg dflags this_mod tidy_binds
-
-
+         -- We grab the the unfoldings at this point.
+       ; (pcs_simpl, tidy_binds, orphan_rules)
+             <- simplThenTidy dflags pcs_tc hst this_mod is_exported ds_binds ds_rules
+           
            -------------------
            -- BUILD THE NEW ModDetails AND ModIface
            -------------------
-       ; let new_details = mkModDetails env_tc local_insts tidy_binds 
-                                        top_level_ids orphan_rules
-       ; final_iface <- mkFinalIface dflags location maybe_checked_iface 
-                                     new_iface new_details
+       ; let new_details = mkModDetails env_tc tidy_binds orphan_rules
+       ; final_iface <- _scc_ "MkFinalIface" 
+                         mkFinalIface ghci_mode dflags location 
+                                      maybe_checked_iface new_iface new_details
 
            -------------------
-           -- COMPLETE CODE GENERATION
+           -- CONVERT TO STG and COMPLETE CODE GENERATION
            -------------------
-       ; (maybe_stub_h_filename, maybe_stub_c_filename, maybe_ibinds)
+       ; (maybe_stub_h_filename, maybe_stub_c_filename, maybe_bcos)
             <- restOfCodeGeneration dflags toInterp this_mod
                   (map ideclName (hsModuleImports rdr_module))
-                  cost_centre_info foreign_stuff env_tc stg_binds oa_tidy_binds
-                  hit (pcs_PIT pcs_tc)       
+                  foreign_stuff env_tc tidy_binds
+                  hit (pcs_PIT pcs_simpl)       
 
          -- and the answer is ...
-       ; return (HscOK new_details (Just final_iface)
-                       maybe_stub_h_filename maybe_stub_c_filename
-                       maybe_ibinds pcs_tc)
+       ; return (HscRecomp pcs_simpl new_details final_iface
+                            maybe_stub_h_filename maybe_stub_c_filename
+                           maybe_bcos)
          }}}}}}}
 
 
 
-mkFinalIface dflags location maybe_old_iface new_iface new_details
+mkFinalIface ghci_mode dflags location maybe_old_iface new_iface new_details
  = case completeIface maybe_old_iface new_iface new_details of
       (new_iface, Nothing) -- no change in the interfacfe
          -> do when (dopt Opt_D_dump_hi_diffs dflags)
@@ -240,29 +263,34 @@ mkFinalIface dflags location maybe_old_iface new_iface new_details
                              "UNCHANGED FINAL INTERFACE" (pprIface new_iface)
               return new_iface
       (new_iface, Just sdoc_diffs)
-         -> do dumpIfSet_dyn dflags Opt_D_dump_hi_diffs "INTERFACE HAS CHANGED" sdoc_diffs
-               dumpIfSet_dyn dflags Opt_D_dump_hi "NEW FINAL INTERFACE" (pprIface new_iface)
+         -> do dumpIfSet_dyn dflags Opt_D_dump_hi_diffs "INTERFACE HAS CHANGED" 
+                                    sdoc_diffs
+               dumpIfSet_dyn dflags Opt_D_dump_hi "NEW FINAL INTERFACE" 
+                                    (pprIface new_iface)
                -- Write the interface file
-               writeIface (unJust (ml_hi_file location) "hscRecomp:hi") new_iface
+               when (ghci_mode /= Interactive) 
+                    (writeIface (unJust "hscRecomp:hi" (ml_hi_file location))
+                                new_iface)
                return new_iface
 
 
 myParseModule dflags src_filename
  = do --------------------------  Parser  ----------------
       showPass dflags "Parser"
-      -- _scc_     "Parser"
+      _scc_  "Parser" do
 
       buf <- hGetStringBuffer True{-expand tabs-} src_filename
 
       let glaexts | dopt Opt_GlasgowExts dflags = 1#
-                 | otherwise                 = 0#
+                 | otherwise                   = 0#
 
-      case parse buf PState{ bol = 0#, atbol = 1#,
-                            context = [], glasgow_exts = glaexts,
-                            loc = mkSrcLoc (_PK_ src_filename) 1 } of {
+      case parseModule buf PState{ bol = 0#, atbol = 1#,
+                                  context = [], glasgow_exts = glaexts,
+                                  loc = mkSrcLoc (_PK_ src_filename) 1 } of {
 
        PFailed err -> do { hPutStrLn stderr (showSDoc err);
                             return Nothing };
+
        POk _ rdr_module@(HsModule mod_name _ _ _ _ _ _) -> do {
 
       dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ;
@@ -274,26 +302,48 @@ myParseModule dflags src_filename
       }}
 
 
-restOfCodeGeneration dflags toInterp this_mod imported_module_names cost_centre_info 
-                     foreign_stuff env_tc stg_binds oa_tidy_binds
+simplThenTidy dflags pcs hst this_mod is_exported binds rules
+ = do -- Do main Core-language transformations ---------
+      -- _scc_     "Core2Core"
+      (simplified, orphan_rules) 
+         <- core2core dflags pcs hst is_exported binds rules
+
+      -- Do saturation and convert to A-normal form
+      -- NOTE: subsequent passes may not transform the syntax, only annotate it
+      saturated <- coreSatPgm dflags simplified
+
+      -- Do the final tidy-up
+      (pcs', tidy_binds, tidy_orphan_rules) 
+         <- tidyCorePgm dflags this_mod pcs saturated orphan_rules
+      
+      return (pcs', tidy_binds, tidy_orphan_rules)
+
+
+restOfCodeGeneration dflags toInterp this_mod imported_module_names
+                     foreign_stuff env_tc tidy_binds
                      hit pit -- these last two for mapping ModNames to Modules
  | toInterp
- = do (ibinds,itbl_env) 
-         <- stgToInterpSyn (map fst stg_binds) local_tycons local_classes
-      return (Nothing, Nothing, Just (ibinds,itbl_env))
+ = do (bcos,itbl_env) 
+         <- byteCodeGen dflags tidy_binds local_tycons local_classes
+      return (Nothing, Nothing, Just (bcos,itbl_env))
 
  | otherwise
- = do --------------------------  Code generation -------------------------------
-      -- _scc_     "CodeGen"
-      abstractC <- codeGen dflags this_mod imported_modules
+ = do
+      --------------------------  Convert to STG -------------------------------
+      (stg_binds, cost_centre_info) 
+               <- _scc_ "CoreToStg"
+                   myCoreToStg dflags this_mod tidy_binds env_tc
+
+      --------------------------  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
-                       oa_tidy_binds stg_binds
+                       tidy_binds stg_binds
                        c_code h_code abstractC
 
       return (maybe_stub_h_name, maybe_stub_c_name, Nothing)
@@ -301,7 +351,7 @@ restOfCodeGeneration dflags toInterp this_mod imported_module_names cost_centre_
     local_tycons     = typeEnvTyCons env_tc
     local_classes    = typeEnvClasses env_tc
     imported_modules = map mod_name_to_Module imported_module_names
-    (fe_binders,h_code,c_code) = foreign_stuff
+    (h_code,c_code,fe_binders) = foreign_stuff
 
     mod_name_to_Module :: ModuleName -> Module
     mod_name_to_Module nm
@@ -315,45 +365,25 @@ restOfCodeGeneration dflags toInterp this_mod imported_module_names cost_centre_
                        (ppr nm)
 
 
-dsThenSimplThenTidy dflags rule_base this_mod print_unqual is_exported tc_result hst
- = do --------------------------  Desugaring ----------------
-      -- _scc_     "DeSugar"
-      (desugared, rules, h_code, c_code, fe_binders) 
-         <- deSugar dflags this_mod print_unqual hst tc_result
-
-      --------------------------  Main Core-language transformations ----------------
-      -- _scc_     "Core2Core"
-      (simplified, orphan_rules) 
-         <- core2core dflags rule_base hst is_exported desugared rules
-
-      -- Do the final tidy-up
-      (tidy_binds, tidy_orphan_rules) 
-         <- tidyCorePgm dflags this_mod simplified orphan_rules
-      
-      return (tidy_binds, tidy_orphan_rules, (fe_binders,h_code,c_code))
-
-
-myCoreToStg dflags this_mod tidy_binds
+myCoreToStg dflags this_mod tidy_binds env_tc
  = do 
-      c2s_uniqs <- mkSplitUniqSupply 'c'
-      st_uniqs  <- mkSplitUniqSupply 'g'
-      let occ_anal_tidy_binds = occurAnalyseBinds tidy_binds
-
-      () <- coreBindsSize occ_anal_tidy_binds `seq` return ()
+      () <- coreBindsSize tidy_binds `seq` return ()
       -- TEMP: the above call zaps some space usage allocated by the
       -- simplifier, which for reasons I don't understand, persists
       -- thoroughout code generation
 
-      showPass dflags "Core2Stg"
-      -- _scc_     "Core2Stg"
-      let stg_binds   = topCoreBindsToStg c2s_uniqs occ_anal_tidy_binds
+      --let bcos = byteCodeGen dflags tidy_binds local_tycons local_classes
+
+      
+      stg_binds <- _scc_ "Core2Stg" coreToStg dflags this_mod tidy_binds
 
-      showPass dflags "Stg2Stg"
-      -- _scc_     "Stg2Stg"
-      (stg_binds2, cost_centre_info) <- stg2stg dflags this_mod st_uniqs stg_binds
-      let final_ids = collectFinalStgBinders (map fst stg_binds2)
+      (stg_binds2, cost_centre_info)
+          <- _scc_ "Core2Stg" stg2stg dflags this_mod stg_binds
 
-      return (stg_binds2, occ_anal_tidy_binds, cost_centre_info, final_ids)
+      return (stg_binds2, cost_centre_info)
+   where
+      local_tycons  = typeEnvTyCons env_tc
+      local_classes = typeEnvClasses env_tc
 \end{code}
 
 
@@ -363,6 +393,8 @@ myCoreToStg dflags this_mod tidy_binds
 %*                                                                     *
 %************************************************************************
 
+\begin{code}
+#ifdef GHCI
 hscExpr
   :: DynFlags
   -> HomeSymbolTable   
@@ -370,20 +402,95 @@ hscExpr
   -> PersistentCompilerState    -- IN: persistent compiler state
   -> Module                    -- Context for compiling
   -> String                    -- The expression
-  -> IO HscResult
-
-hscExpr dflags hst hit pcs this_module expr
-  = do {       -- Parse it
-       ; maybe_parsed <- myParseExpr dflags expr
-       ; case maybe_parsed of {
-            Nothing -> return (HscFail pcs_ch);
+  -> 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
+   = do {
+       maybe_parsed <- hscParseExpr dflags expr;
+       case maybe_parsed of
+            Nothing -> return (pcs0, Nothing)
             Just parsed_expr -> do {
 
                -- Rename it
-         (new_pcs, maybe_renamed_expr) <- renameExpr dflags hit hst pcs this_module parsed_expr ;
-         case maybe_renamed_expr of {
-               Nothing -> 
+       (pcs1, maybe_renamed_expr) <- 
+               renameExpr dflags hit hst pcs0 this_module parsed_expr;
+       case maybe_renamed_expr of
+               Nothing -> return ({-WAS:pcs1-} pcs0, Nothing)
+               Just (print_unqual, rn_expr) -> do {
+
+               -- Typecheck it
+       maybe_tc_return
+          <- typecheckExpr dflags 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;
+       
+               -- Simplify it
+       simpl_expr <- simplifyExpr dflags pcs2 hst ds_expr;
+
+               -- Saturate it
+       sat_expr <- coreSatExpr dflags simpl_expr;
+
+               -- ToDo: need to do SRTs?
+
+               -- Convert to BCOs
+       bcos <- coreExprToBCOs dflags sat_expr
+
+       return (pcs2, Just (bcos, print_unqual, ty));
+     }}}}
+
+hscParseExpr :: DynFlags -> String -> IO (Maybe RdrNameHsExpr)
+hscParseExpr dflags str
+ = do --------------------------  Parser  ----------------
+      showPass dflags "Parser"
+      _scc_ "Parser" do
+
+      buf <- stringToStringBuffer str
+
+      let glaexts | dopt Opt_GlasgowExts dflags = 1#
+                         | otherwise             = 0#
+
+      case parseExpr buf PState{ bol = 0#, atbol = 1#,
+                                context = [], glasgow_exts = glaexts,
+                                loc = mkSrcLoc SLIT("<no file>") 0 } of {
 
+       PFailed err -> do { hPutStrLn stderr (showSDoc err);
+                           freeStringBuffer buf;
+                            return Nothing };
+
+       POk _ rdr_expr -> do {
+
+      --ToDo: can't free the string buffer until we've finished this
+      -- compilation sweep and all the identifiers have gone away.
+      --freeStringBuffer buf;
+      dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_expr);
+      return (Just rdr_expr)
+      }}
+#endif
+\end{code}
 
 %************************************************************************
 %*                                                                     *
@@ -405,14 +512,15 @@ initPersistentCompilerState
         )
 
 initPersistentRenamerState :: IO PersistentRenamerState
-  = do ns <- mkSplitUniqSupply 'r'
+  = do us <- mkSplitUniqSupply 'r'
        return (
-        PRS { prsOrig  = Orig { origNames  = initOrigNames,
-                               origIParam = emptyFM },
-             prsDecls = (emptyNameEnv, 0),
-             prsInsts = (emptyBag, 0),
-             prsRules = (emptyBag, 0),
-             prsNS    = ns
+        PRS { prsOrig  = NameSupply { nsUniqs = us,
+                                     nsNames = initOrigNames,
+                                     nsIPs   = emptyFM },
+             prsDecls   = (emptyNameEnv, 0),
+             prsInsts   = (emptyBag, 0),
+             prsRules   = (emptyBag, 0),
+             prsImpMods = emptyFM
             }
         )