[project @ 2002-05-03 11:23:41 by simonmar]
[ghc-hetmet.git] / ghc / compiler / main / HscMain.lhs
index 8e82ede..b3c1450 100644 (file)
@@ -16,9 +16,9 @@ module HscMain ( HscResult(..), hscMain,
 #ifdef GHCI
 import Interpreter
 import ByteCodeGen     ( byteCodeGen )
-import CoreTidy                ( tidyCoreExpr )
+import TidyPgm         ( tidyCoreExpr )
 import CorePrep                ( corePrepExpr )
-import Rename          ( renameStmt, renameRdrName, slurpIface )
+import Rename          ( renameStmt,    renameRdrName, slurpIface )
 import RdrName          ( rdrNameOcc, setRdrNameOcc )
 import RdrHsSyn                ( RdrNameStmt )
 import OccName          ( dataName, tcClsName, 
@@ -26,7 +26,7 @@ import OccName          ( dataName, tcClsName,
 import Type            ( Type )
 import Id              ( Id, idName, setGlobalIdDetails )
 import IdInfo          ( GlobalIdDetails(VanillaGlobal) )
-import Name            ( isLocalName )
+import Name            ( isInternalName )
 import NameEnv         ( lookupNameEnv )
 import Module          ( lookupModuleEnv )
 import RdrName         ( rdrEnvElts )
@@ -47,7 +47,8 @@ import Parser
 import Lex             ( ParseResult(..), ExtFlags(..), mkPState )
 import SrcLoc          ( mkSrcLoc )
 import Finder          ( findModule )
-import Rename          ( checkOldIface, renameModule, closeIfaceDecls )
+import Rename          ( checkOldIface, renameModule, renameExtCore, 
+                         closeIfaceDecls, RnResult(..) )
 import Rules           ( emptyRuleBase )
 import PrelInfo                ( wiredInThingEnv, wiredInThings )
 import PrelRules       ( builtinRules )
@@ -59,7 +60,7 @@ import Desugar
 import Flattening       ( flatten, flattenExpr )
 import SimplCore
 import CoreUtils       ( coreBindsSize )
-import CoreTidy                ( tidyCorePgm )
+import TidyPgm         ( tidyCorePgm )
 import CorePrep                ( corePrepPgm )
 import StgSyn
 import CoreToStg       ( coreToStg )
@@ -70,8 +71,8 @@ import CodeOutput     ( codeOutput, outputForeignStubs )
 import Module          ( ModuleName, moduleName, mkHomeModule )
 import CmdLineOpts
 import DriverState     ( v_HCHeader )
+import DriverPhases     ( isExtCore_file )
 import ErrUtils                ( dumpIfSet_dyn, showPass, printError )
-import Util            ( unJust )
 import UniqSupply      ( mkSplitUniqSupply )
 
 import Bag             ( consBag, emptyBag )
@@ -83,6 +84,9 @@ import OccName                ( OccName )
 import Name            ( Name, nameModule, nameOccName, getName )
 import NameEnv         ( emptyNameEnv, mkNameEnv )
 import Module          ( Module )
+import FastString
+import Maybes          ( expectJust )
+import Util            ( seqList )
 
 import IOExts          ( newIORef, readIORef, writeIORef, 
                          unsafePerformIO )
@@ -92,6 +96,9 @@ import Maybe          ( isJust, fromJust )
 import IO
 
 import MkExternalCore  ( emitExternalCore )
+import ParserCore
+import ParserCoreUtils
+
 \end{code}
 
 
@@ -201,49 +208,36 @@ hscRecomp ghci_mode dflags have_object
          mod location maybe_checked_iface hst hit pcs_ch
  = do  {
          -- what target are we shooting for?
-       ; let toInterp = dopt_HscLang dflags == HscInterpreted
+       ; let toInterp  = dopt_HscLang dflags == HscInterpreted
        ; let toNothing = dopt_HscLang dflags == HscNothing
+       ; let toCore    = isJust (ml_hs_file location) &&
+                         isExtCore_file (fromJust (ml_hs_file location))
 
        ; when (ghci_mode /= OneShot && verbosity dflags >= 1) $
                hPutStrLn stderr ("Compiling " ++ 
                        showModMsg (not toInterp) mod location);
+                       
+       ; front_res <- 
+               (if toCore then hscCoreFrontEnd else hscFrontEnd)
+                  ghci_mode dflags location hst hit pcs_ch
+       ; case front_res of
+           Left flure -> return flure;
+           Right (this_mod, rdr_module, 
+                  dont_discard, new_iface, 
+                  pcs_tc, ds_details, foreign_stuff) -> do {
+
+         let {
+           imported_module_names = 
+               filter (/= gHC_PRIM_Name) $
+               map ideclName (hsModuleImports rdr_module);
 
-           -------------------
-           -- PARSE
-           -------------------
-       ; 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 = mkHomeModule (hsModuleName rdr_module)
-    
-           -------------------
-           -- RENAME
-           -------------------
-       ; (pcs_rn, print_unqual, maybe_rn_result) 
-            <- _scc_ "Rename" 
-                renameModule dflags ghci_mode hit hst pcs_ch this_mod rdr_module
-       ; case maybe_rn_result of {
-            Nothing -> return (HscFail pcs_ch);
-            Just (dont_discard, new_iface, rn_result) -> do {
+            imported_modules =
+               map (moduleNameToModule hit (pcs_PIT pcs_tc))
+                       imported_module_names;
+         }
 
-           -------------------
-           -- TYPECHECK
-           -------------------
-       ; maybe_tc_result 
-           <- _scc_ "TypeCheck" 
-              typecheckModule dflags pcs_rn hst print_unqual rn_result
-       ; case maybe_tc_result of {
-            Nothing -> return (HscFail pcs_ch);
-            Just (pcs_tc, tc_result) -> do {
-    
-           -------------------
-           -- DESUGAR
-           -------------------
-       ; (ds_details, foreign_stuff) 
-             <- _scc_ "DeSugar" 
-               deSugar dflags pcs_tc hst this_mod print_unqual tc_result
+       -- force this out now, so we don't keep a hold of rdr_module or pcs_tc
+       ; seqList imported_modules (return ())
 
            -------------------
            -- FLATTENING
@@ -267,11 +261,20 @@ hscRecomp ghci_mode dflags have_object
                                             pcs_rules = rules }
                  else return pcs_tc
 
+-- Should we remove bits of flat_details at this point?
+--        ; flat_details <- case flat_details of
+--                            ModDetails { md_binds = binds } ->
+--                                return ModDetails { md_binds = binds,
+--                                                    md_rules = [],
+--                                                    md_types = emptyTypeEnv,
+--                                                    md_insts = [] }
+
        -- alive at this point:  
        --      pcs_middle
        --      foreign_stuff
-       --      ds_details
-       --      new_iface               
+       --      flat_details
+       --      imported_modules (seq'd)
+       --      new_iface
 
            -------------------
            -- SIMPLIFY
@@ -326,15 +329,6 @@ hscRecomp ghci_mode dflags have_object
            local_tycons     = typeEnvTyCons  env_tc
            local_classes    = typeEnvClasses env_tc
 
-           imported_module_names = 
-               filter (/= gHC_PRIM_Name) $
-               map ideclName (hsModuleImports rdr_module)
-               -- eek! doesn't this keep rdr_module live until code generation?
-               -- SDM 3/2002
-
-           mod_name_to_Module nm
-                = do m <- findModule nm ; return (fst (fromJust m))
-
            (h_code, c_code, headers, fe_binders) = foreign_stuff
 
            -- turn the list of headers requested in foreign import
@@ -343,7 +337,7 @@ hscRecomp ghci_mode dflags have_object
            --
            foreign_headers =   
                unlines 
-             . map (\fname -> "#include \"" ++ _UNPK_ fname ++ "\"")
+             . map (\fname -> "#include \"" ++ unpackFS fname ++ "\"")
              . reverse 
              $ headers
 
@@ -353,8 +347,6 @@ hscRecomp ghci_mode dflags have_object
         ; fhdrs <- readIORef v_HCHeader
         ; writeIORef v_HCHeader (fhdrs ++ foreign_headers)
 
-        ; imported_modules <- mapM mod_name_to_Module imported_module_names
-
        ; (stub_h_exists, stub_c_exists, maybe_bcos, final_iface )
           <- if toInterp
 #ifdef GHCI
@@ -418,18 +410,97 @@ hscRecomp ghci_mode dflags have_object
                            final_iface
                             stub_h_exists stub_c_exists
                            maybe_bcos)
-         }}}}}}}
+        }}
+
+hscCoreFrontEnd ghci_mode dflags location hst hit pcs_ch = do {
+           -------------------
+           -- PARSE
+           -------------------
+       ; inp <- readFile (expectJust "hscCoreFrontEnd:hspp" (ml_hspp_file location))
+       ; case parseCore inp 1 of
+           FailP s        -> hPutStrLn stderr s >> return (Left (HscFail pcs_ch));
+           OkP rdr_module -> do {
+       ; let this_mod = mkHomeModule (hsModuleName rdr_module)
+    
+           -------------------
+           -- RENAME
+           -------------------
+       ; (pcs_rn, print_unqual, maybe_rn_result) 
+            <- renameExtCore dflags hit hst pcs_ch this_mod rdr_module
+       ; case maybe_rn_result of {
+            Nothing -> return (Left (HscFail pcs_ch));
+            Just (dont_discard, new_iface, rn_decls) -> do {
+
+           -------------------
+           -- TYPECHECK
+           -------------------
+       ; maybe_tc_result 
+           <- _scc_ "TypeCheck" 
+              typecheckCoreModule dflags pcs_rn hst new_iface rn_decls
+       ; case maybe_tc_result of {
+            Nothing -> return (Left (HscFail pcs_ch));
+            Just (pcs_tc, tc_result) -> do {
+    
+           -------------------
+           -- DESUGAR
+           -------------------
+       ; (ds_details, foreign_stuff) <- deSugarCore tc_result
+       ; return (Right (this_mod, rdr_module, dont_discard, new_iface,
+                        pcs_tc, ds_details, foreign_stuff))
+       }}}}}}
+        
+
+hscFrontEnd ghci_mode dflags location hst hit pcs_ch = do {
+           -------------------
+           -- PARSE
+           -------------------
+       ; maybe_parsed <- myParseModule dflags 
+                             (expectJust "hscRecomp:hspp" (ml_hspp_file location))
+       ; case maybe_parsed of {
+            Nothing -> return (Left (HscFail pcs_ch));
+            Just rdr_module -> do {
+       ; let this_mod = mkHomeModule (hsModuleName rdr_module)
+    
+           -------------------
+           -- RENAME
+           -------------------
+       ; (pcs_rn, print_unqual, maybe_rn_result) 
+            <- _scc_ "Rename" 
+                renameModule dflags ghci_mode hit hst pcs_ch this_mod rdr_module
+       ; case maybe_rn_result of {
+            Nothing -> return (Left (HscFail pcs_ch));
+            Just (dont_discard, new_iface, rn_result) -> do {
+
+           -------------------
+           -- TYPECHECK
+           -------------------
+       ; maybe_tc_result 
+           <- _scc_ "TypeCheck" 
+              typecheckModule dflags pcs_rn hst print_unqual rn_result
+       ; case maybe_tc_result of {
+            Nothing -> return (Left (HscFail pcs_ch));
+            Just (pcs_tc, tc_result) -> do {
+    
+           -------------------
+           -- DESUGAR
+           -------------------
+       ; (ds_details, foreign_stuff) 
+             <- _scc_ "DeSugar" 
+               deSugar dflags pcs_tc hst this_mod print_unqual tc_result
+       ; return (Right (this_mod, rdr_module, dont_discard, new_iface,
+                        pcs_tc, ds_details, foreign_stuff))
+       }}}}}}}
+
 
 myParseModule dflags src_filename
  = do --------------------------  Parser  ----------------
       showPass dflags "Parser"
       _scc_  "Parser" do
-
-      buf <- hGetStringBuffer True{-expand tabs-} src_filename
+      buf <- hGetStringBuffer src_filename
 
       let exts = ExtFlags {glasgowExtsEF = dopt Opt_GlasgowExts dflags,
                           parrEF        = dopt Opt_PArr        dflags}
-         loc  = mkSrcLoc (_PK_ src_filename) 1
+         loc  = mkSrcLoc (mkFastString src_filename) 1
 
       case parseModule buf (mkPState loc exts) of {
 
@@ -602,7 +673,7 @@ hscParseStmt dflags str
 
       let exts = ExtFlags {glasgowExtsEF = dopt Opt_GlasgowExts dflags,
                           parrEF        = dopt Opt_PArr        dflags}
-         loc  = mkSrcLoc SLIT("<interactive>") 1
+         loc  = mkSrcLoc FSLIT("<interactive>") 1
 
       case parseStmt buf (mkPState loc exts) of {
 
@@ -673,7 +744,7 @@ hscThing dflags hst hit pcs0 ic str
             Nothing -> return (pcs, []);
             Just pcs ->
                let do_lookup n
-                       | isLocalName n = lookupNameEnv (ic_type_env ic) n
+                       | isInternalName n = lookupNameEnv (ic_type_env ic) n
                        | otherwise     = lookupType hst (pcs_PTE pcs) n
                
                    maybe_ty_things = map do_lookup names
@@ -686,7 +757,7 @@ myParseIdentifier dflags str
  
        let exts = ExtFlags {glasgowExtsEF = dopt Opt_GlasgowExts dflags,
                            parrEF        = dopt Opt_PArr        dflags}
-          loc  = mkSrcLoc SLIT("<interactive>") 1
+          loc  = mkSrcLoc FSLIT("<interactive>") 1
 
        case parseIdentifier buf (mkPState loc exts) of