[project @ 2000-11-22 10:01:45 by sewardj]
[ghc-hetmet.git] / ghc / compiler / main / HscMain.lhs
index d6ae43c..8360fc0 100644 (file)
@@ -4,30 +4,35 @@
 \section[GHC_Main]{Main driver for Glasgow Haskell compiler}
 
 \begin{code}
-module HscMain ( HscResult(..), hscMain, 
+module HscMain ( HscResult(..), hscMain, hscExpr, hscTypeExpr,
                 initPersistentCompilerState ) where
 
 #include "HsVersions.h"
 
-import Maybe           ( isJust )
-import IO              ( hPutStrLn, stderr )
+#ifdef GHCI
+import RdrHsSyn                ( RdrNameHsExpr )
+import CoreToStg       ( coreToStgExpr )
+import StringBuffer    ( stringToStringBuffer, freeStringBuffer )
+#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
 import Rules           ( emptyRuleBase )
 import PrelInfo                ( wiredInThingEnv, wiredInThings )
 import PrelNames       ( knownKeyNames )
 import MkIface         ( completeIface, mkModDetailsFromIface, mkModDetails,
                          writeIface, pprIface )
-import TcModule                ( TcResults(..), typecheckModule )
+import TcModule
+import Type
+import TcHsSyn
 import InstEnv         ( emptyInstEnv )
-import Desugar         ( deSugar )
-import SimplCore       ( core2core )
+import Desugar
+import SimplCore
 import OccurAnal       ( occurAnalyseBinds )
 import CoreUtils       ( coreBindsSize )
 import CoreTidy                ( tidyCorePgm )
@@ -37,21 +42,25 @@ 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 )
+import Unique          ( Uniquable(..) )
+import PrelNames       ( ioTyConKey )
 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, 
                          typeEnvClasses, typeEnvTyCons, emptyIfaceTable )
+import Type            ( splitTyConApp_maybe )
 import FiniteMap       ( FiniteMap, plusFM, emptyFM, addToFM )
 import OccName         ( OccName )
 import Name            ( Name, nameModule, nameOccName, getName  )
@@ -59,6 +68,8 @@ import Name           ( emptyNameEnv )
 import Module          ( Module, lookupModuleEnvByName )
 
 import Monad           ( when )
+import Maybe           ( isJust )
+import IO              ( hPutStrLn, stderr )
 \end{code}
 
 
@@ -70,19 +81,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 ([UnlinkedIBind],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 +110,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 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 +129,20 @@ 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
+ = let bomb = panic "hscNoRecomp:OneShot"
+   in  return (HscNoRecomp pcs_ch bomb bomb)
+ | otherwise
  = 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";
+
       -- CLOSURE
       (pcs_cl, closure_errs, cl_hs_decls) 
          <- closeIfaceDecls dflags hit hst pcs_ch old_iface ;
@@ -130,31 +151,27 @@ 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
+      let env_tc      = tc_env tc_result
           local_insts = tc_insts 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
       ;
-      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) $
+               hPutStrLn stderr "compilation IS required";
 
          -- what target are we shooting for?
        ; let toInterp = dopt_HscLang dflags == HscInterpreted
@@ -162,41 +179,42 @@ 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
            -------------------
+        ; showPass dflags "Rename"
        ; (pcs_rn, maybe_rn_result) 
             <- 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 
+        ; showPass dflags "Typecheck"
+       ; maybe_tc_result <- 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
+       ; let env_tc        = tc_env tc_result
              local_insts   = tc_insts tc_result
 
            -------------------
            -- DESUGAR, SIMPLIFY, TIDY-CORE
            -------------------
          -- 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
+       ; simpl_result <- dsThenSimplThenTidy dflags pcs_tc hst this_mod 
+                                             print_unqualified is_exported tc_result
        ; let (tidy_binds, orphan_rules, foreign_stuff) = simpl_result
            
            -------------------
@@ -211,8 +229,8 @@ hscRecomp dflags location maybe_checked_iface hst hit pcs_ch
            -------------------
        ; 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
+       ; final_iface <- mkFinalIface ghci_mode dflags location 
+                                      maybe_checked_iface new_iface new_details
 
            -------------------
            -- COMPLETE CODE GENERATION
@@ -224,14 +242,14 @@ hscRecomp dflags location maybe_checked_iface hst hit pcs_ch
                   hit (pcs_PIT pcs_tc)       
 
          -- 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_tc new_details final_iface
+                            maybe_stub_h_filename maybe_stub_c_filename
+                           maybe_ibinds)
          }}}}}}}
 
 
 
-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,10 +258,14 @@ 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
 
 
@@ -263,7 +285,8 @@ myParseModule dflags src_filename
 
        PFailed err -> do { hPutStrLn stderr (showSDoc err);
                             return Nothing };
-       POk _ rdr_module@(HsModule mod_name _ _ _ _ _ _) -> do {
+
+       POk _ (PModule rdr_module@(HsModule mod_name _ _ _ _ _ _)) -> do {
 
       dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ;
       
@@ -279,7 +302,8 @@ restOfCodeGeneration dflags toInterp this_mod imported_module_names cost_centre_
                      hit pit -- these last two for mapping ModNames to Modules
  | toInterp
  = do (ibinds,itbl_env) 
-         <- stgToInterpSyn (map fst stg_binds) local_tycons local_classes
+         <- stgBindsToInterpSyn dflags (map fst stg_binds) 
+               local_tycons local_classes
       return (Nothing, Nothing, Just (ibinds,itbl_env))
 
  | otherwise
@@ -315,18 +339,20 @@ 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
+dsThenSimplThenTidy dflags pcs hst this_mod print_unqual is_exported tc_result
  = do --------------------------  Desugaring ----------------
+      showPass dflags "DeSugar"
       -- _scc_     "DeSugar"
       (desugared, rules, h_code, c_code, fe_binders) 
-         <- deSugar dflags this_mod print_unqual hst tc_result
+         <- deSugar dflags pcs hst this_mod print_unqual tc_result
 
       --------------------------  Main Core-language transformations ----------------
       -- _scc_     "Core2Core"
       (simplified, orphan_rules) 
-         <- core2core dflags rule_base hst is_exported desugared rules
+         <- core2core dflags pcs hst is_exported desugared rules
 
       -- Do the final tidy-up
+      showPass dflags "TidyCore"
       (tidy_binds, tidy_orphan_rules) 
          <- tidyCorePgm dflags this_mod simplified orphan_rules
       
@@ -335,7 +361,6 @@ dsThenSimplThenTidy dflags rule_base this_mod print_unqual is_exported tc_result
 
 myCoreToStg dflags this_mod tidy_binds
  = do 
-      c2s_uniqs <- mkSplitUniqSupply 'c'
       st_uniqs  <- mkSplitUniqSupply 'g'
       let occ_anal_tidy_binds = occurAnalyseBinds tidy_binds
 
@@ -344,9 +369,8 @@ myCoreToStg dflags this_mod tidy_binds
       -- 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
+      stg_binds <- topCoreBindsToStg dflags occ_anal_tidy_binds
 
       showPass dflags "Stg2Stg"
       -- _scc_     "Stg2Stg"
@@ -363,6 +387,14 @@ myCoreToStg dflags this_mod tidy_binds
 %*                                                                     *
 %************************************************************************
 
+\begin{code}
+#ifndef GHCI
+hscExpr dflags hst hit pcs this_module expr
+  = panic "hscExpr: non-interactive build"
+hscTypeExpr dflags hst hit pcs0 this_module expr
+  = panic "hscTypeExpr: non-interactive build"
+#else 
+
 hscExpr
   :: DynFlags
   -> HomeSymbolTable   
@@ -370,20 +402,128 @@ hscExpr
   -> PersistentCompilerState    -- IN: persistent compiler state
   -> Module                    -- Context for compiling
   -> String                    -- The expression
-  -> IO HscResult
+  -> IO ( PersistentCompilerState, Maybe UnlinkedIExpr )
 
-hscExpr dflags hst hit pcs this_module expr
+hscExpr dflags hst hit pcs0 this_module expr
+   = do {
+       -- parse, rename & typecheck the expression
+        (pcs1, maybe_tc_result)
+          <- hscExprFrontEnd dflags hst hit pcs0 this_module expr;
+
+       case maybe_tc_result of {
+          Nothing -> return (pcs1, Nothing);
+          Just (print_unqual, 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 (not is_IO_type)
+               then hscExpr dflags hst hit pcs1 this_module 
+                       ("print (" ++ expr ++ ")")
+               else do
+
+               -- Desugar it
+       ds_expr <- deSugarExpr dflags pcs1 hst this_module
+                       print_unqual tc_expr;
+       
+               -- Simplify it
+       simpl_expr <- simplifyExpr dflags pcs1 hst ds_expr;
+
+               -- Convert to STG
+       stg_expr <- coreToStgExpr dflags simpl_expr;
+
+               -- ToDo: need to do StgVarInfo?  or SRTs?
+
+               -- Convert to InterpSyn
+       unlinked_iexpr <- stgExprToInterpSyn dflags stg_expr;
+
+       return (pcs1, Just unlinked_iexpr);
+     }}}
+
+hscExprFrontEnd
+  :: DynFlags
+  -> HomeSymbolTable   
+  -> HomeIfaceTable
+  -> PersistentCompilerState    -- IN: persistent compiler state
+  -> Module                    -- Context for compiling
+  -> String                    -- The expression
+  -> IO ( PersistentCompilerState, 
+         Maybe (PrintUnqualified,TypecheckedHsExpr,Type) 
+       )
+hscExprFrontEnd dflags hst hit pcs0 this_module expr
   = do {       -- Parse it
-       ; maybe_parsed <- myParseExpr dflags expr
-       ; case maybe_parsed of {
-            Nothing -> return (HscFail pcs_ch);
+       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 (pcs1, 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 (pcs1, Nothing)
+               Just (pcs2, tc_expr, ty) -> 
+                  return (pcs2, Just (print_unqual, tc_expr, ty))
+    }}}
+
+hscTypeExpr
+  :: DynFlags
+  -> HomeSymbolTable   
+  -> HomeIfaceTable
+  -> PersistentCompilerState    -- IN: persistent compiler state
+  -> Module                    -- Context for compiling
+  -> String                    -- The expression
+  -> IO (PersistentCompilerState, Maybe Type)
+hscTypeExpr dflags hst hit pcs0 this_module expr
+  = do (pcs1, maybe_tc_result)
+         <- hscExprFrontEnd dflags hst hit pcs0 this_module expr
+       case maybe_tc_result of
+         Nothing -> return (pcs1, Nothing)
+         Just (_,_,ty) -> return (pcs1, Just ty)
+
+hscParseExpr :: DynFlags -> String -> IO (Maybe RdrNameHsExpr)
+hscParseExpr dflags str
+ = do --------------------------  Parser  ----------------
+      showPass dflags "Parser"
+      -- _scc_     "Parser"
+
+      buf <- stringToStringBuffer ("__expr " ++ str)
 
+      -- glaexts is True for now (because of the daft __expr at the front
+      -- of the string...)
+      let glaexts = 1#
+      --let glaexts | dopt Opt_GlasgowExts dflags = 1#
+      --           | otherwise                   = 0#
+
+      case parse buf PState{ bol = 0#, atbol = 1#,
+                            context = [], glasgow_exts = glaexts,
+                            loc = mkSrcLoc SLIT("<no file>") 0 } of {
+
+       PFailed err -> do { freeStringBuffer buf;
+                           hPutStrLn stderr (showSDoc err);
+                            return Nothing };
+
+       POk _ (PExpr 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}
 
 %************************************************************************
 %*                                                                     *