From: sewardj Date: Fri, 27 Oct 2000 13:50:26 +0000 (+0000) Subject: [project @ 2000-10-27 13:50:25 by sewardj] X-Git-Tag: Approximately_9120_patches~3489 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=6ef5df4a1bc630798e0de5e676afe11086b68606;p=ghc-hetmet.git [project @ 2000-10-27 13:50:25 by sewardj] Half-way through versioning so it will compile, sans interpreter, with 4.08.1 --- diff --git a/ghc/compiler/ghci/CmLink.lhs b/ghc/compiler/ghci/CmLink.lhs index de465b3..70a5f42 100644 --- a/ghc/compiler/ghci/CmLink.lhs +++ b/ghc/compiler/ghci/CmLink.lhs @@ -89,20 +89,6 @@ link :: PackageConfigInfo -> PersistentLinkerState -> IO LinkResult -#ifndef GHCI_NOTYET ---link = panic "CmLink.link: not implemented" -link pci groups pls1 - = do putStrLn "Hello from the Linker!" - putStrLn (showSDoc (vcat (map ppLinkableSCC groups))) - putStrLn "Bye-bye from the Linker!" - return (LinkOK pls1) - -ppLinkableSCC :: SCC Linkable -> SDoc -ppLinkableSCC (CyclicSCC xs) = ppr xs -ppLinkableSCC (AcyclicSCC x) = ppr [x] - - -#else link pci [] pls = return (LinkOK pls) link pci (group:groups) pls = do -- the group is either all objects or all interpretable, for now @@ -120,7 +106,6 @@ link pci (group:groups) pls = do itbl_env=new_itbl_env}) else return (LinkErrs pls (ptext SLIT("linker: group must contain all objects or all interpreted modules"))) -#endif modname_of_linkable (LM nm _) = nm modname_of_linkable (LP _) = panic "modname_of_linkable: package" diff --git a/ghc/compiler/ghci/Linker.lhs b/ghc/compiler/ghci/Linker.lhs index ab1552a..440ff11 100644 --- a/ghc/compiler/ghci/Linker.lhs +++ b/ghc/compiler/ghci/Linker.lhs @@ -6,22 +6,30 @@ \begin{code} {-# OPTIONS -#include "Linker.h" #-} module Linker ( -#ifdef GHCI loadObj, -- :: String -> IO () unloadObj, -- :: String -> IO () lookupSymbol, -- :: String -> IO (Maybe Addr) resolveObjs, -- :: IO () linkPrelude -- tmp -#endif ) where import IO import Exception import Addr import PrelByteArr -import PrelPack (packString) +import PrelPack (packString) +import Panic ( panic ) + +#if __GLASGOW_HASKELL__ <= 408 +loadObj = bogus "loadObj" +unloadObj = bogus "unloadObj" +lookupSymbol = bogus "lookupSymbol" +resolveObjs = bogus "resolveObjs" +linkPrelude = bogus "linkPrelude" +bogus f = panic ("Linker." ++ f ++ ": this hsc was built without an interpreter.") + +#else -#ifdef GHCI linkPrelude = do hPutStr stderr "Loading HSstd_cbits.o..." loadObj "/home/simonmar/builds/i386-unknown-linux-boot/ghc/lib/std/cbits/HSstd_cbits.o" @@ -86,5 +94,5 @@ foreign import "unloadObj" unsafe foreign import "resolveObjs" unsafe c_resolveObjs :: IO Int -#endif /* GHCI */ +#endif /* __GLASGOW_HASKELL__ <= 408 */ \end{code} diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs index 06735fe..092b924 100644 --- a/ghc/compiler/main/DriverPipeline.hs +++ b/ghc/compiler/main/DriverPipeline.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverPipeline.hs,v 1.9 2000/10/27 11:48:55 sewardj Exp $ +-- $Id: DriverPipeline.hs,v 1.10 2000/10/27 13:50:25 sewardj Exp $ -- -- GHC Driver -- @@ -39,11 +39,9 @@ import Config import Util import MkIface ( pprIface ) -import Posix import Directory import System import IOExts --- import Posix commented out temp by SLPJ to get going on windows import Exception import IO @@ -574,7 +572,7 @@ run_phase SplitMangle _basename _suff input_fn _output_fn -- this is the prefix used for the split .s files tmp_pfx <- readIORef v_TmpDir - x <- getProcessID + x <- myGetProcessID let split_s_prefix = tmp_pfx ++ "/ghc" ++ show x writeIORef v_Split_prefix split_s_prefix addFilesToClean [split_s_prefix ++ "__*"] -- d:-) diff --git a/ghc/compiler/main/DriverUtil.hs b/ghc/compiler/main/DriverUtil.hs index 2a4a599..9a92b83 100644 --- a/ghc/compiler/main/DriverUtil.hs +++ b/ghc/compiler/main/DriverUtil.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverUtil.hs,v 1.4 2000/10/26 16:21:02 sewardj Exp $ +-- $Id: DriverUtil.hs,v 1.5 2000/10/27 13:50:25 sewardj Exp $ -- -- Utils for the driver -- @@ -72,7 +72,6 @@ instance Typeable BarfKind where ----------------------------------------------------------------------------- -- Reading OPTIONS pragmas - getOptionsFromSource :: String -- input file -> IO [String] -- options, if any diff --git a/ghc/compiler/main/Finder.lhs b/ghc/compiler/main/Finder.lhs index b92848a..1f7addb 100644 --- a/ghc/compiler/main/Finder.lhs +++ b/ghc/compiler/main/Finder.lhs @@ -24,6 +24,7 @@ import Directory import List import IO import Monad +import Outputable ( showSDoc, ppr ) -- debugging only \end{code} The Finder provides a thin filesystem abstraction to the rest of the @@ -45,13 +46,22 @@ initFinder :: PackageConfigInfo -> IO () initFinder (PackageConfigInfo pkgs) = do -- expunge our home cache writeIORef v_HomeDirCache Nothing - -- lazilly fill in the package cache writeIORef v_PkgDirCache (unsafePerformIO (newPkgCache pkgs)) + pkg_dbg_info <- readIORef v_PkgDirCache + putStrLn (unlines (map show (fmToList pkg_dbg_info))) - findModule :: ModuleName -> IO (Maybe (Module, ModuleLocation)) findModule name = do + hPutStr stderr ("findModule: " ++ moduleNameUserString name ++ " ... ") + maybe_m <- findModule_wrk name + case maybe_m of + Nothing -> hPutStrLn stderr "Not Found" + Just mm -> hPutStrLn stderr (showSDoc (ppr (snd mm))) + return maybe_m + +findModule_wrk :: ModuleName -> IO (Maybe (Module, ModuleLocation)) +findModule_wrk name = do j <- maybeHomeModule name case j of Just home_module -> return (Just home_module) @@ -148,9 +158,9 @@ maybePackageModule mod_name = do Just (pkg_name,path) -> return (Just (mkModule mod_name pkg_name, ModuleLocation{ - hs_file = error "package module; no source", + hs_file = "error:_package_module;_no_source", hi_file = hi, - obj_file = error "package module; no object" + obj_file = "error:_package_module;_no_object" } )) diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index ab35159..7ef69b2 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -62,7 +62,7 @@ import HscTypes ( ModDetails, ModIface(..), PersistentCompilerState(..), GenAvailInfo(..), RdrAvailInfo, OrigNameEnv(..), PackageRuleBase, HomeIfaceTable, PackageIfaceTable, extendTypeEnv, groupTyThings, TypeEnv, TyThing, - typeEnvClasses, typeEnvTyCons ) + typeEnvClasses, typeEnvTyCons, emptyIfaceTable ) import RnMonad ( ExportItem, ParsedIface(..) ) import CmSummarise ( ModSummary(..), name_of_summary, ms_get_imports, mimp_name ) @@ -111,6 +111,7 @@ hscMain dflags summary maybe_old_iface hst hit pcs -- ????? source_unchanged :: Bool -- extracted from summary? let source_unchanged = trace "WARNING: source_unchanged?!" False ; + putStrLn "checking old iface ..."; (pcs_ch, check_errs, (recomp_reqd, maybe_checked_iface)) <- checkOldIface dflags hit hst pcs (ms_mod summary) source_unchanged maybe_old_iface; @@ -122,6 +123,7 @@ hscMain dflags summary maybe_old_iface hst hit pcs what_next | recomp_reqd || no_old_iface = hscRecomp | otherwise = hscNoRecomp ; + putStrLn "doing what_next ..."; what_next dflags summary maybe_checked_iface hst hit pcs_ch }} @@ -376,7 +378,8 @@ initPersistentCompilerState :: IO PersistentCompilerState initPersistentCompilerState = do prs <- initPersistentRenamerState return ( - PCS { pcs_PST = initPackageDetails, + PCS { pcs_PIT = emptyIfaceTable, + pcs_PST = initPackageDetails, pcs_insts = emptyInstEnv, pcs_rules = emptyRuleBase, pcs_PRS = prs diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index 1b119c4..ec776c7 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -9,7 +9,7 @@ module HscTypes ( ModDetails(..), ModIface(..), GlobalSymbolTable, HomeSymbolTable, PackageSymbolTable, - HomeIfaceTable, PackageIfaceTable, + HomeIfaceTable, PackageIfaceTable, emptyIfaceTable, lookupTable, lookupTableByModName, IfaceDecls(..), @@ -71,7 +71,7 @@ import Type ( Type ) import FiniteMap ( FiniteMap, emptyFM, addToFM, lookupFM, foldFM ) import Bag ( Bag ) import Maybes ( seqMaybe ) -import UniqFM ( UniqFM ) +import UniqFM ( UniqFM, emptyUFM ) import Outputable import SrcLoc ( SrcLoc, isGoodSrcLoc ) import Util ( thenCmp ) @@ -90,7 +90,11 @@ data ModuleLocation hs_file :: FilePath, hi_file :: FilePath, obj_file :: FilePath - } + } + deriving Show + +instance Outputable ModuleLocation where + ppr = text . show \end{code} For a module in another package, the hs_file and obj_file @@ -181,6 +185,9 @@ type PackageIfaceTable = IfaceTable type HomeSymbolTable = SymbolTable -- Domain = modules in the home package type PackageSymbolTable = SymbolTable -- Domain = modules in the some other package type GlobalSymbolTable = SymbolTable -- Domain = all modules + +emptyIfaceTable :: IfaceTable +emptyIfaceTable = emptyUFM \end{code} Simple lookups in the symbol table. diff --git a/ghc/compiler/main/Main.hs b/ghc/compiler/main/Main.hs index 9e91f96..1831200 100644 --- a/ghc/compiler/main/Main.hs +++ b/ghc/compiler/main/Main.hs @@ -1,6 +1,6 @@ {-# OPTIONS -W -fno-warn-incomplete-patterns #-} ----------------------------------------------------------------------------- --- $Id: Main.hs,v 1.12 2000/10/27 11:48:55 sewardj Exp $ +-- $Id: Main.hs,v 1.13 2000/10/27 13:50:25 sewardj Exp $ -- -- GHC Driver program -- @@ -259,16 +259,3 @@ setTopDir args = do return others beginMake = panic "`ghc --make' unimplemented" - ------------------------------------------------------------------------------ --- compatibility code - -#if __GLASGOW_HASKELL__ <= 408 -catchJust = catchIO -ioErrors = justIoErrors -throwTo = raiseInThread -#endif - -#ifdef mingw32_TARGET_OS -foreign import "_getpid" getProcessID :: IO Int -#endif diff --git a/ghc/compiler/main/TmpFiles.hs b/ghc/compiler/main/TmpFiles.hs index 39e05b9..dd45242 100644 --- a/ghc/compiler/main/TmpFiles.hs +++ b/ghc/compiler/main/TmpFiles.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: TmpFiles.hs,v 1.4 2000/10/24 13:23:33 sewardj Exp $ +-- $Id: TmpFiles.hs,v 1.5 2000/10/27 13:50:25 sewardj Exp $ -- -- Temporary file management -- @@ -21,9 +21,6 @@ import Config import Util -- hslibs -#ifndef mingw32_TARGET_OS -import Posix ( getProcessID ) -#endif import Exception import IOExts @@ -59,16 +56,9 @@ cleanTempFiles verbose = do type Suffix = String -- find a temporary name that doesn't already exist. -#ifdef mingw32_TARGET_OS -getProcessID :: IO Int -getProcessID - = do putStr "warning: faking getProcessID in main/TmpFiles.lhs" - return 12345 -#endif - newTempName :: Suffix -> IO FilePath newTempName extn = do - x <- getProcessID + x <- myGetProcessID tmp_dir <- readIORef v_TmpDir findTempName tmp_dir x where findTempName tmp_dir x = do diff --git a/ghc/compiler/stgSyn/StgInterp.lhs b/ghc/compiler/stgSyn/StgInterp.lhs index a0d7c1d..8e98946 100644 --- a/ghc/compiler/stgSyn/StgInterp.lhs +++ b/ghc/compiler/stgSyn/StgInterp.lhs @@ -9,7 +9,6 @@ module StgInterp ( ClosureEnv, ItblEnv, linkIModules, stgToInterpSyn, --- runStgI -- tmp, for testing ) where {- ----------------------------------------------------------------------------- @@ -30,7 +29,16 @@ module StgInterp ( #include "HsVersions.h" -#ifdef GHCI +#if __GLASGOW_HASKELL__ <= 408 + +import Panic ( panic ) +type ItblEnv = () +type ClosureEnv = () +linkIModules = panic "StgInterp.linkIModules: this hsc was not built with an interpreter" +stgToInterpSyn = panic "StgInterp.linkIModules: this hsc was not built with an interpreter" + +#else + import Linker import Id ( Id, idPrimRep ) import Outputable @@ -61,7 +69,6 @@ import CTypes import FastString import GlaExts ( Int(..) ) import Module ( moduleNameFS ) -#endif import TyCon ( TyCon, isDataTyCon, tyConDataCons, tyConFamilySize ) import Class ( Class, classTyCon ) @@ -1227,5 +1234,6 @@ load addr = do x <- peek addr foreign import "strncpy" strncpy :: Addr -> ByteArray# -> CInt -> IO () +#endif /* #if __GLASGOW_HASKELL__ <= 408 */ \end{code} diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs index 0f3d2a0..feea95c 100644 --- a/ghc/compiler/utils/Util.lhs +++ b/ghc/compiler/utils/Util.lhs @@ -53,16 +53,26 @@ module Util ( #endif , global + , myProcessID + +#if __GLASGOW_HASKELL__ <= 408 + , catchJust + , ioErrors + , throwTo +#endif ) where #include "HsVersions.h" +import IO ( hPutStrLn, stderr ) import List ( zipWith4 ) import Panic ( panic ) import IOExts ( IORef, newIORef, unsafePerformIO ) import FastTypes - +#if __GLASGOW__HASKELL__ <= 408 +import Exception ( catchIO, justIoErrors, raiseInThread ) +#endif infixr 9 `thenCmp` \end{code} @@ -704,3 +714,20 @@ global :: a -> IORef a global a = unsafePerformIO (newIORef a) \end{code} +Compatibility stuff: + +\begin{code} +#if __GLASGOW_HASKELL__ <= 408 +catchJust = catchIO +ioErrors = justIoErrors +throwTo = raiseInThread +#endif + +#ifdef mingw32_TARGET_OS +foreign import "_getpid" myProcessID :: IO Int +#else +myProcessID :: IO Int +myProcessID = do hPutStrLn stderr "Warning:myProcessID" + return 12345 +#endif +\end{code}