[project @ 2000-10-25 14:42:31 by sewardj]

Compile up to HscMain.  Again :)

ghc/compiler/coreSyn/CoreTidy.lhs

@@ -76,7 +76,7 @@ tidyCorePgm dflags module_name binds_in orphans_in
 
         binds_in1 <- if opt_UsageSPOn
                      then _scc_ "CoreUsageSPInf"
-                                doUsageSPInf dflags us binds_in 
+                                doUsageSPInf dflags us binds_in
                      else return binds_in
 
 	let (tidy_env1, binds_out)  = mapAccumL (tidyBind (Just module_name))

ghc/compiler/deSugar/Desugar.lhs

@@ -24,6 +24,7 @@ import DsForeign	( dsForeigns )
 import DsExpr		()	-- Forces DsExpr to be compiled; DsBinds only
 				-- depends on DsExpr.hi-boot.
 import Module		( Module )
+import Id		( Id )
 import VarEnv
 import VarSet
 import Bag		( isEmptyBag )

ghc/compiler/main/CodeOutput.lhs

@@ -66,7 +66,7 @@ codeOutput dflags mod_name tycons classes core_binds stg_binds
     do let filenm = dopt_OutName dflags 
        stub_names <- outputForeignStubs dflags c_code h_code
        case dopt_HscLang dflags of
-          HscInterpreter -> return stub_names
+          HscInterpreted -> return stub_names
           HscAsm         -> outputAsm dflags filenm flat_abstractC ncg_uniqs
                             >> return stub_names
           HscC           -> outputC dflags filenm flat_abstractC	

ghc/compiler/main/DriverPipeline.hs

 -----------------------------------------------------------------------------
--- $Id: DriverPipeline.hs,v 1.5 2000/10/23 09:03:27 simonpj Exp $
+-- $Id: DriverPipeline.hs,v 1.6 2000/10/25 14:42:32 sewardj Exp $
 --
 -- GHC Driver
 --
@@ -731,11 +731,8 @@ data CompResult
                        -- summary and code; Nothing => compilation not reqd
                        -- (old summary and code are still valid)
               PersistentCompilerState	-- updated PCS
-              (Bag WarnMsg) 		-- warnings
 
    | CompErrs PersistentCompilerState	-- updated PCS
-              (Bag ErrMsg)		-- errors
-              (Bag WarnMsg)             -- warnings
 
 
 compile finder summary old_iface hst pcs = do 

ghc/compiler/main/HscMain.lhs

@@ -76,22 +76,65 @@ hscMain
   -> IO HscResult
 
 hscMain dflags core_cmds stg_cmds summary maybe_old_iface
-	output_filename mod_details pcs1 
- = do
-      source_unchanged :: Bool -- extracted from summary?
+	output_filename mod_details pcs
+ = do {
+      -- ????? source_unchanged :: Bool -- extracted from summary?
+
+      (ch_pcs, check_errs, (recomp_reqd, maybe_checked_iface))
+         <- checkOldIface dflags finder hit hst pcs mod source_unchanged
+                          maybe_old_iface;
+      if check_errs then
+         return (HscFail ch_pcs)
+      else do {
 
-      (pcs2, check_errs, (recomp_reqd, maybe_checked_iface))
-         <- checkOldIface dflags finder hit hst pcs1 mod source_unchanged
-                          maybe_old_iface
+      let no_old_iface = not (isJust maybe_checked_iface)
+          what_next | recomp_reqd || no_old_iface = hscRecomp 
+                    | otherwise                   = hscNoRecomp
 
-      -- test check_errs and give up if a problem happened
-      what_next = if recomp_reqd then hscRecomp else hscNoRecomp
+      return (what_next dflags core_cmds stg_cmds summary hit hst 
+                        pcs2 maybe_checked_iface)
+      }}
 
-      return $
-         what_next dflags core_cmds stg_cmds summary hit hst 
-                   pcs2 maybe_checked_iface
 
-hscNoRecomp = panic "hscNoRecomp"
+hscNoRecomp dflags core_cmds stg_cmds summary hit hst pcs maybe_old_iface
+ = do {
+      -- we definitely expect to have the old interface available
+      old_iface = case maybe_old_iface of 
+                     Just old_if -> old_if
+                     Nothing -> panic "hscNoRecomp:old_iface"
+
+      -- CLOSURE
+      (pcs_cl, closure_errs, cl_hs_decls) 
+         <- closeIfaceDecls dflags finder hit hst pcs old_iface
+      if closure_errs then 
+         return (HscFail cl_pcs) 
+      else do {
+
+      -- TYPECHECK
+      maybe_tc_result
+         <- typecheckModule dflags mod pcs_cl hst hit pit cl_hs_decls;
+      case maybe_tc_result of {
+         Nothing -> return (HscFail cl_pcs);
+         Just tc_result -> do {
+
+      let pcs_tc        = tc_pcs tc_result
+          env_tc        = tc_env tc_result
+          binds_tc      = tc_binds tc_result
+          local_tycons  = tc_tycons tc_result
+          local_classes = tc_classes 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 final_details
+		    Nothing -- tells CM to use old iface and linkables
+		    Nothing Nothing -- foreign export stuff
+                    Nothing -- ibinds
+		    pcs_tc)
+      }}}}
+
 
 hscRecomp dflags core_cmds stg_cmds summary hit hst pcs maybe_old_iface
  = do {
@@ -119,22 +162,24 @@ hscRecomp dflags core_cmds stg_cmds summary hit hst pcs maybe_old_iface
          Just tc_result -> do {
 
       let pcs_tc        = tc_pcs tc_result
-      let env_tc        = tc_env tc_result
-      let binds_tc      = tc_binds tc_result
-      let local_tycons  = tc_tycons tc_result
-      let local_classes = tc_classes tc_result
+          env_tc        = tc_env tc_result
+          binds_tc      = tc_binds tc_result
+          local_tycons  = tc_tycons tc_result
+          local_classes = tc_classes tc_result
+          local_insts   = tc_insts tc_result
 
       -- DESUGAR, SIMPLIFY, TIDY-CORE
       -- We grab the the unfoldings at this point.
-      (tidy_binds, orphan_rules, fe_binders, h_code, c_code)   -- return modDetails?
-         <- dsThenSimplThenTidy dflags mod tc_result rule_base ds_uniqs
+      (tidy_binds, orphan_rules, foreign_stuff)
+         <- dsThenSimplThenTidy dflags mod tc_result ds_uniqs
 
       -- CONVERT TO STG
       (stg_binds, cost_centre_info, top_level_ids) 
          <- myCoreToStg c2s_uniqs st_uniqs this_mod tidy_binds
 
       -- cook up a new ModDetails now we (finally) have all the bits
-      let new_details = completeModDetails tc_env tidy_binds top_level_ids orphan_rules
+      let new_details = mkModDetails tc_env local_insts tidy_binds 
+			             top_level_ids orphan_rules
 
       -- and possibly create a new ModIface
       let maybe_final_iface = completeIface maybe_old_iface new_iface new_details 
@@ -143,7 +188,7 @@ hscRecomp dflags core_cmds stg_cmds summary hit hst pcs maybe_old_iface
       (maybe_ibinds, maybe_stub_h_filename, maybe_stub_c_filename) 
          <- restOfCodeGeneration toInterp
                                  this_mod imported_modules cost_centre_info 
-                                 fe_binders local_tycons local_classes stg_binds
+                                 fe_binders tc_env stg_binds
 
       -- and the answer is ...
       return (HscOK new_details maybe_final_iface 
@@ -184,10 +229,10 @@ myParseModule dflags summary
 
 
 restOfCodeGeneration toInterp this_mod imported_modules cost_centre_info 
-                     fe_binders local_tycons local_classes stg_binds
+                     foreign_stuff tc_env stg_binds
  | toInterp
- = return (Nothing, Nothing, stgToInterpSyn stg_binds local_tycons local_classes)
-
+ = return (Nothing, Nothing, 
+	   Just (stgToInterpSyn stg_binds local_tycons local_classes))
  | otherwise
  = do --------------------------  Code generation -------------------------------
       show_pass "CodeGen"
@@ -199,19 +244,24 @@ restOfCodeGeneration toInterp this_mod imported_modules cost_centre_info
       --------------------------  Code output -------------------------------
       show_pass "CodeOutput"
       -- _scc_     "CodeOutput"
+      let (fe_binders, h_code, c_code) = foreign_stuff
       (maybe_stub_h_name, maybe_stub_c_name)
          <- codeOutput this_mod local_tycons local_classes
                        occ_anal_tidy_binds stg_binds2
                        c_code h_code abstractC ncg_uniqs
 
-      return (maybe_stub_h_name, maybe_stub_c_name, [{-UnlinkedIBind-}])
+      return (maybe_stub_h_name, maybe_stub_c_name, Nothing)
+ where
+    local_tycons  = tcEnvTyCons tc_env
+    local_classes = tcEnvClasses tc_env
 
 
-dsThenSimplThenTidy dflags mod tc_result rule_base ds_uniqs
+dsThenSimplThenTidy dflags mod tc_result
+-- make up ds_uniqs here
  = do --------------------------  Desugaring ----------------
       -- _scc_     "DeSugar"
       (desugared, rules, h_code, c_code, fe_binders) 
-         <- deSugar this_mod ds_uniqs tc_results
+         <- deSugar this_mod ds_uniqs tc_result
 
       --------------------------  Main Core-language transformations ----------------
       -- _scc_     "Core2Core"
@@ -221,8 +271,7 @@ dsThenSimplThenTidy dflags mod tc_result rule_base ds_uniqs
       (tidy_binds, tidy_orphan_rules) 
          <- tidyCorePgm this_mod simplified orphan_rules
       
-      return (tidy_binds, tidy_orphan_rules, fe_binders, h_code, c_code)
-
+      return (tidy_binds, tidy_orphan_rules, (fe_binders,h_code,c_code))
 
 
 myCoreToStg c2s_uniqs st_uniqs this_mod tidy_binds

ghc/compiler/rename/Rename.lhs

@@ -4,7 +4,7 @@
 \section[Rename]{Renaming and dependency analysis passes}
 
 \begin{code}
-module Rename ( renameModule ) where
+module Rename ( renameModule, closeIfaceDecls ) where
 
 #include "HsVersions.h"
 

ghc/compiler/stgSyn/StgInterp.lhs

@@ -9,7 +9,7 @@ module StgInterp (
     ClosureEnv, ItblEnv,
     linkIModules,
     stgToInterpSyn,
-    runStgI  -- tmp, for testing
+--    runStgI  -- tmp, for testing
  ) where
 
 {- -----------------------------------------------------------------------------
@@ -64,7 +64,7 @@ import Module		( moduleNameFS )
 #endif
 
 import TyCon		( TyCon, isDataTyCon, tyConDataCons, tyConFamilySize )
-import Class		( Class )
+import Class		( Class, classTyCon )
 import InterpSyn
 import StgSyn
 import Addr
@@ -85,15 +85,10 @@ type ClosureEnv = FiniteMap RdrName HValue
 -- Run our STG program through the interpreter
 -- ---------------------------------------------------------------------------
 
+#if 0
+-- To be nuked at some point soon.
 runStgI :: [TyCon] -> [Class] -> [StgBinding] -> IO Int
 
-#ifndef GHCI
-runStgI	      = panic "StgInterp.runStgI: not implemented"
-linkIModules  = panic "StgInterp.linkIModules: not implemented"
-#else
-
-
-
 -- the bindings need to have a binding for stgMain, and the
 -- body of it had better represent something of type Int# -> Int#
 runStgI tycons classes stgbinds
@@ -128,6 +123,7 @@ runStgI tycons classes stgbinds
                            emptyUFM{-initial de-}
                     )
         return result
+#endif
 
 -- ---------------------------------------------------------------------------
 -- Convert STG to an unlinked interpretable
@@ -140,7 +136,7 @@ stgToInterpSyn :: [StgBinding]
 stgToInterpSyn binds local_tycons local_classes
  = do let ibinds = concatMap (translateBind emptyUniqSet) binds
       let tycs   = local_tycons ++ map classTyCon local_classes
-      itblenv <- makeItbls tycs
+      itblenv <- mkITbls tycs
       return (ibinds, itblenv)
 
 
@@ -421,7 +417,7 @@ linkIModules :: ClosureEnv -- incoming global closure env; returned updated
 	     -> ItblEnv    -- incoming global itbl env; returned updated
 	     -> [([UnlinkedIBind], ItblEnv)]
 	     -> IO ([LinkedIBind], ItblEnv, ClosureEnv)
-linkIModules gie gce mods = do
+linkIModules gce gie mods = do
   let (bindss, ies) = unzip mods
       binds  = concat bindss
       top_level_binders = map (toRdrName.binder) binds
@@ -431,9 +427,9 @@ linkIModules gie gce mods = do
       new_gce = addListToFM gce (zip top_level_binders new_rhss)
       new_rhss = map (\b -> evalP (bindee b) emptyUFM) new_binds
     ---vvvvvvvvv---------------------------------------^^^^^^^^^-- circular
-      (new_binds, final_gce) = linkIBinds final_gie new_gce binds
+      new_binds = linkIBinds final_gie new_gce binds
 
-  return (new_binds, final_gie, final_gce)
+  return (new_binds, final_gie, new_gce)
 
 
 -- We're supposed to augment the environments with the values of any
@@ -1231,6 +1227,5 @@ load addr = do x <- peek addr
 
 foreign import "strncpy" strncpy :: Addr -> ByteArray# -> CInt -> IO ()
 
-#endif /* ndef GHCI */
 \end{code}