diff options
| -rw-r--r-- | .gitignore | 1 | ||||
| -rw-r--r-- | ghc.mk | 1 | ||||
| -rw-r--r-- | includes/rts/FileLock.h | 6 | ||||
| -rw-r--r-- | mk/validate-settings.mk | 6 | ||||
| -rw-r--r-- | packages | 1 | ||||
| -rw-r--r-- | rts/FileLock.c (renamed from rts/posix/FileLock.c) | 11 | ||||
| -rw-r--r-- | rts/FileLock.h (renamed from rts/posix/FileLock.h) | 0 | ||||
| -rw-r--r-- | rts/GetTime.h | 3 | ||||
| -rw-r--r-- | rts/Linker.c | 5 | ||||
| -rw-r--r-- | rts/RtsStartup.c | 9 | ||||
| -rw-r--r-- | rts/posix/GetTime.c | 36 | ||||
| -rw-r--r-- | rts/win32/GetTime.c | 74 | ||||
| -rwxr-xr-x | sync-all | 36 | ||||
| -rw-r--r-- | utils/ghc-cabal/Main.hs | 44 | ||||
| -rw-r--r-- | utils/ghctags/Main.hs | 12 |
15 files changed, 155 insertions, 90 deletions
diff --git a/.gitignore b/.gitignore index e65a4c26ec..2bbf8004be 100644 --- a/.gitignore +++ b/.gitignore @@ -74,6 +74,7 @@ _darcs/ /libraries/stm/ /libraries/template-haskell/ /libraries/terminfo/ +/libraries/transformers /libraries/unix/ /libraries/utf8-string/ /libraries/vector/ @@ -419,6 +419,7 @@ $(eval $(call addPackage,Cabal/Cabal)) $(eval $(call addPackage,binary)) $(eval $(call addPackage,bin-package-db)) $(eval $(call addPackage,hoopl)) +$(eval $(call addPackage,transformers)) $(eval $(call addPackage,mtl)) $(eval $(call addPackage,utf8-string)) $(eval $(call addPackage,xhtml)) diff --git a/includes/rts/FileLock.h b/includes/rts/FileLock.h index a7d8d3cfed..e863883c51 100644 --- a/includes/rts/FileLock.h +++ b/includes/rts/FileLock.h @@ -14,11 +14,9 @@ #ifndef RTS_FILELOCK_H #define RTS_FILELOCK_H -#ifdef HAVE_SYS_TYPES_H -#include <sys/types.h> -#endif +#include "Stg.h" -int lockFile(int fd, dev_t dev, ino_t ino, int for_writing); +int lockFile(int fd, StgWord64 dev, StgWord64 ino, int for_writing); int unlockFile(int fd); #endif /* RTS_FILELOCK_H */ diff --git a/mk/validate-settings.mk b/mk/validate-settings.mk index fa5add53a1..b8a48394b9 100644 --- a/mk/validate-settings.mk +++ b/mk/validate-settings.mk @@ -95,9 +95,15 @@ libraries/hoopl/src/Compiler/Hoopl/XUtil_HC_OPTS += -Wwarn libraries/hoopl/src/Compiler/Hoopl/Pointed_HC_OPTS += -Wwarn libraries/hoopl/src/Compiler/Hoopl/Passes/Dominator_HC_OPTS += -Wwarn +# temporarily turn off -Werror for mtl +libraries/mtl_dist-install_EXTRA_HC_OPTS += -Wwarn + # primitive has a warning about deprecated use of GHC.IOBase libraries/primitive_dist-install_EXTRA_HC_OPTS += -Wwarn +# temporarily turn off -Werror for transformers +libraries/transformers_dist-install_EXTRA_HC_OPTS += -Wwarn + # vector has some unused match warnings libraries/vector_dist-install_EXTRA_HC_OPTS += -Wwarn @@ -70,6 +70,7 @@ libraries/pretty - packages/pretty.git libraries/process - packages/process.git git libraries/template-haskell - packages/template-haskell.git git libraries/terminfo - packages/terminfo.git git +libraries/transformers - packages/transformers.git git libraries/unix - packages/unix.git git libraries/utf8-string - packages/utf8-string.git git libraries/Win32 - packages/Win32.git git diff --git a/rts/posix/FileLock.c b/rts/FileLock.c index cb36366070..44ff67140c 100644 --- a/rts/posix/FileLock.c +++ b/rts/FileLock.c @@ -14,13 +14,12 @@ #include "RtsUtils.h" #include <sys/types.h> -#include <sys/stat.h> #include <unistd.h> #include <errno.h> typedef struct { - dev_t device; - ino_t inode; + StgWord64 device; + StgWord64 inode; int readers; // >0 : readers, <0 : writers } Lock; @@ -45,8 +44,8 @@ static int cmpLocks(StgWord w1, StgWord w2) static int hashLock(HashTable *table, StgWord w) { Lock *l = (Lock *)w; - // Just xor the dev_t with the ino_t, hope this is good enough. - return hashWord(table, (StgWord)l->inode ^ (StgWord)l->device); + // Just xor all 32-bit words of inode and device, hope this is good enough. + return hashWord(table, l->inode ^ (l->inode >> 32) ^ l->device ^ (l->device >> 32)); } void @@ -76,7 +75,7 @@ freeFileLocking(void) } int -lockFile(int fd, dev_t dev, ino_t ino, int for_writing) +lockFile(int fd, StgWord64 dev, StgWord64 ino, int for_writing) { Lock key, *lock; diff --git a/rts/posix/FileLock.h b/rts/FileLock.h index 72ab170437..72ab170437 100644 --- a/rts/posix/FileLock.h +++ b/rts/FileLock.h diff --git a/rts/GetTime.h b/rts/GetTime.h index 86c5511df9..45804aa3a9 100644 --- a/rts/GetTime.h +++ b/rts/GetTime.h @@ -11,6 +11,9 @@ #include "BeginPrivate.h" +void initializeTimer (void); +StgWord64 getMonotonicNSec (void); + Time getProcessCPUTime (void); Time getThreadCPUTime (void); Time getProcessElapsedTime (void); diff --git a/rts/Linker.c b/rts/Linker.c index df5ab5c44a..15e61badc6 100644 --- a/rts/Linker.c +++ b/rts/Linker.c @@ -304,8 +304,6 @@ typedef struct _RtsSymbolVal { SymI_HasProto(__hscore_get_saved_termios) \ SymI_HasProto(__hscore_set_saved_termios) \ SymI_HasProto(shutdownHaskellAndSignal) \ - SymI_HasProto(lockFile) \ - SymI_HasProto(unlockFile) \ SymI_HasProto(signal_handlers) \ SymI_HasProto(stg_sig_install) \ SymI_HasProto(rtsTimerSignal) \ @@ -1283,6 +1281,9 @@ typedef struct _RtsSymbolVal { SymI_HasProto(n_capabilities) \ SymI_HasProto(stg_traceCcszh) \ SymI_HasProto(stg_traceEventzh) \ + SymI_HasProto(getMonotonicNSec) \ + SymI_HasProto(lockFile) \ + SymI_HasProto(unlockFile) \ RTS_USER_SIGNALS_SYMBOLS \ RTS_INTCHAR_SYMBOLS diff --git a/rts/RtsStartup.c b/rts/RtsStartup.c index 307a691352..f5c29f4a70 100644 --- a/rts/RtsStartup.c +++ b/rts/RtsStartup.c @@ -35,6 +35,7 @@ #include "Profiling.h" #include "Timer.h" #include "Globals.h" +#include "FileLock.h" void exitLinker( void ); // there is no Linker.h file to include #if defined(RTS_GTK_FRONTPANEL) @@ -52,7 +53,6 @@ void exitLinker( void ); // there is no Linker.h file to include #if !defined(mingw32_HOST_OS) #include "posix/TTY.h" -#include "posix/FileLock.h" #endif #ifdef HAVE_UNISTD_H @@ -128,6 +128,9 @@ hs_init_ghc(int *argc, char **argv[], RtsConfig rts_config) /* Initialise the stats department, phase 0 */ initStats0(); + /* Initialize system timer before starting to collect stats */ + initializeTimer(); + /* Next we do is grab the start time...just in case we're * collecting timing statistics. */ @@ -212,9 +215,7 @@ hs_init_ghc(int *argc, char **argv[], RtsConfig rts_config) initGlobalStore(); /* initialise file locking, if necessary */ -#if !defined(mingw32_HOST_OS) initFileLocking(); -#endif #if defined(DEBUG) /* initialise thread label table (tso->char*) */ @@ -373,9 +374,7 @@ hs_exit_(rtsBool wait_foreign) exitLinker(); /* free file locking tables, if necessary */ -#if !defined(mingw32_HOST_OS) freeFileLocking(); -#endif /* free the stable pointer table */ exitStablePtrTable(); diff --git a/rts/posix/GetTime.c b/rts/posix/GetTime.c index 549b3b0878..da8d0fa629 100644 --- a/rts/posix/GetTime.c +++ b/rts/posix/GetTime.c @@ -33,6 +33,19 @@ // we'll implement getProcessCPUTime() and getProcessElapsedTime() // separately, using getrusage() and gettimeofday() respectively +#ifdef darwin_HOST_OS +static double timer_scaling_factor_ns = 0.0; +#endif + +void initializeTimer() +{ +#ifdef darwin_HOST_OS + mach_timebase_info_data_t info; + (void) mach_timebase_info(&info); + timer_scaling_factor_ns = (double)info.numer / (double)info.denom * 1e9; +#endif +} + Time getProcessCPUTime(void) { #if !defined(BE_CONSERVATIVE) && defined(HAVE_CLOCK_GETTIME) && defined (_SC_CPUTIME) && defined(CLOCK_PROCESS_CPUTIME_ID) && defined(HAVE_SYSCONF) @@ -64,32 +77,31 @@ Time getProcessCPUTime(void) } } -Time getProcessElapsedTime(void) +StgWord64 getMonotonicNSec(void) { #ifdef HAVE_CLOCK_GETTIME struct timespec ts; clock_gettime(CLOCK_ID, &ts); - return SecondsToTime(ts.tv_sec) + NSToTime(ts.tv_nsec); + return (StgWord64)ts.tv_sec * 1000000000 + + (StgWord64)ts.tv_nsec; #elif defined(darwin_HOST_OS) uint64_t time = mach_absolute_time(); - static double scaling_factor = 0.0; - - if (scaling_factor == 0.0) { - mach_timebase_info_data_t info; - (void) mach_timebase_info(&info); - scaling_factor = (double)info.numer / (double)info.denom; - } - - return (Time)((double)time * scaling_factor); + return (double)time * timer_scaling_factor_ns; #else struct timeval tv; gettimeofday(&tv, (struct timezone *) NULL); - return SecondsToTime(tv.tv_sec) + USToTime(tv.tv_usec); + return (StgWord64)tv.tv_sec * 1000000000 + + (StgWord64)tv.tv_usec * 1000; #endif } +Time getProcessElapsedTime(void) +{ + return NSToTime(getMonotonicNSec()); +} + void getProcessTimes(Time *user, Time *elapsed) { *user = getProcessCPUTime(); diff --git a/rts/win32/GetTime.c b/rts/win32/GetTime.c index 9a322bf0a5..ec506fe4d0 100644 --- a/rts/win32/GetTime.c +++ b/rts/win32/GetTime.c @@ -47,37 +47,57 @@ getProcessCPUTime(void) return fileTimeToRtsTime(userTime); } -// getProcessElapsedTime relies on QueryPerformanceFrequency -// which should be available on any Windows computer thay you -// would want to run Haskell on. Satnam Singh, 5 July 2010. +// Number of ticks per second used by the QueryPerformanceFrequency +// implementaiton, represented by a 64-bit union type. +static LARGE_INTEGER qpc_frequency = {.QuadPart = 0}; + +// Initialize qpc_frequency. This function should be called before any call to +// getMonotonicNSec. If QPC is not supported on this system, qpc_frequency is +// set to 0. +void initializeTimer() +{ + BOOL qpc_supported = QueryPerformanceFrequency(&qpc_frequency); + if (!qpc_supported) + { + qpc_frequency.QuadPart = 0; + } +} + +HsWord64 +getMonotonicNSec() +{ + if (qpc_frequency.QuadPart) + { + // system_time is a 64-bit union type used to represent the + // tick count returned by QueryPerformanceCounter + LARGE_INTEGER system_time; + + // get the tick count. + QueryPerformanceCounter(&system_time); + + // compute elapsed seconds as double + double secs = (double)system_time.QuadPart / + (double)qpc_frequency.QuadPart; + + // return elapsed time in nanoseconds + return (HsWord64)(secs * 1e9); + } + else // fallback to GetTickCount + { + // NOTE: GetTickCount is a 32-bit millisecond value, so it wraps around + // every 49 days. + DWORD count = GetTickCount(); + + // getTickCount is in milliseconds, so multiply it by 1000000 to get + // nanoseconds. + return (HsWord64)count * 1000000; + } +} Time getProcessElapsedTime(void) { - // frequency represents the number of ticks per second - // used by the QueryPerformanceFrequency implementaiton - // and is represented by a 64-bit union type initially set to 0 - // and updated just once (hence use of static). - static LARGE_INTEGER frequency = {.QuadPart = 0} ; - - // system_time is a 64-bit union type used to represent the - // tick count returned by QueryPerformanceCounter - LARGE_INTEGER system_time ; - - // If this is the first time we are calling getProcessElapsedTime - // then record the ticks per second used by QueryPerformanceCounter - if (frequency.QuadPart == 0) { - QueryPerformanceFrequency(&frequency); - } - - // Get the tick count. - QueryPerformanceCounter(&system_time) ; - - // Return the tick count as a Time value. - // Using double to compute the intermediate value, because a 64-bit - // int would overflow when multiplied by TICK_RESOLUTION in about 81 days. - return fsecondsToTime((double)system_time.QuadPart / - (double)frequency.QuadPart) ; + return NSToTime(getMonotonicNSec()); } Time @@ -769,6 +769,42 @@ EOF chdir($pwd); } + message "== Checking for old mtl repo"; + if (-d "libraries/mtl/.git") { + chdir("libraries/mtl"); + if ((system "git log -1 c67d8f7247c612dc35242bc67e616f7ea35eadb9 > /dev/null 2> /dev/null") == 0) { + print <<EOF; +============================ +ATTENTION! + +You have an old mtl repository in your GHC tree! + +Please remove it (e.g. "rm -r libraries/mtl"), and then run +"./sync-all get" to get the new repository. +============================ +EOF + } + chdir($pwd); + } + + message "== Checking for old Cabal repo"; + if (-d "libraries/Cabal/.git") { + chdir("libraries/Cabal"); + if ((system "git log -1 c8ebd66a32865f72ae03ee0663c62df3d77f08fe > /dev/null 2> /dev/null") == 0) { + print <<EOF; +============================ +ATTENTION! + +You have an old Cabal repository in your GHC tree! + +Please remove it (e.g. "rm -r libraries/Cabal"), and then run +"./sync-all get" to get the new repository. +============================ +EOF + } + chdir($pwd); + } + $? = $ec; } diff --git a/utils/ghc-cabal/Main.hs b/utils/ghc-cabal/Main.hs index 75d1faf9bf..c24f127422 100644 --- a/utils/ghc-cabal/Main.hs +++ b/utils/ghc-cabal/Main.hs @@ -19,6 +19,7 @@ import Distribution.Verbosity import qualified Distribution.InstalledPackageInfo as Installed import qualified Distribution.Simple.PackageIndex as PackageIndex +import Control.Monad import Data.List import Data.Maybe import System.IO @@ -184,36 +185,20 @@ doInstall ghc ghcpkg strip topdir directory distDir htmldir = toPathTemplate "$docdir" } progs = withPrograms lbi - ghcProg = ConfiguredProgram { - programId = programName ghcProgram, - programVersion = Nothing, - programDefaultArgs = ["-B" ++ topdir], - programOverrideArgs = [], - programLocation = UserSpecified ghc - } ghcpkgconf = topdir </> "package.conf.d" - ghcPkgProg = ConfiguredProgram { - programId = programName ghcPkgProgram, - programVersion = Nothing, - programDefaultArgs = ["--global-conf", - ghcpkgconf] - ++ if not (null myDestDir) - then ["--force"] - else [], - programOverrideArgs = [], - programLocation = UserSpecified ghcpkg - } - stripProg = ConfiguredProgram { - programId = programName stripProgram, - programVersion = Nothing, - programDefaultArgs = [], - programOverrideArgs = [], - programLocation = UserSpecified strip - } - progs' = updateProgram ghcProg - $ updateProgram ghcPkgProg - $ updateProgram stripProg - progs + ghcProgram' = ghcProgram { + programPostConf = \_ _ -> return ["-B" ++ topdir], + programFindLocation = \_ -> return (Just ghc) } + ghcPkgProgram' = ghcPkgProgram { + programPostConf = \_ _ -> return $ ["--global-conf", ghcpkgconf] + ++ ["--force" | not (null myDestDir) ], + programFindLocation = \_ -> return (Just ghcpkg) } + stripProgram' = stripProgram { + programFindLocation = \_ -> return (Just strip) } + configurePrograms ps conf = foldM (flip (configureProgram verbosity)) conf ps + + progs' <- configurePrograms [ghcProgram', ghcPkgProgram', stripProgram'] progs + let Just ghcPkgProg = lookupProgram ghcPkgProgram' progs' instInfos <- dump verbosity ghcPkgProg GlobalPackageDB let installedPkgs' = PackageIndex.fromList instInfos let mlc = libraryConfig lbi @@ -404,4 +389,3 @@ generate config_args distdir directory | otherwise = return ("\'" ++ s ++ "\'") boolToYesNo True = "YES" boolToYesNo False = "NO" - diff --git a/utils/ghctags/Main.hs b/utils/ghctags/Main.hs index ea3300c66a..f63e039f39 100644 --- a/utils/ghctags/Main.hs +++ b/utils/ghctags/Main.hs @@ -19,10 +19,13 @@ import MonadUtils ( liftIO ) import SrcLoc -- Every GHC comes with Cabal anyways, so this is not a bad new dependency -import Distribution.Simple.GHC ( ghcOptions ) +import Distribution.Simple.GHC ( componentGhcOptions ) import Distribution.Simple.Configure ( getPersistBuildConfig ) +import Distribution.Simple.Compiler ( compilerVersion ) +import Distribution.Simple.Program.GHC ( renderGhcOptions ) import Distribution.PackageDescription ( library, libBuildInfo ) -import Distribution.Simple.LocalBuildInfo ( localPkgDescr, buildDir, libraryConfig ) +import Distribution.Simple.LocalBuildInfo ( localPkgDescr, buildDir, libraryConfig, compiler ) +import qualified Distribution.Verbosity as V import Control.Monad hiding (mapM) import System.Environment @@ -184,8 +187,9 @@ flagsFromCabal distPref = do (Just lib, Just clbi) -> let bi = libBuildInfo lib odir = buildDir lbi - opts = ghcOptions lbi bi clbi odir - in return opts + opts = componentGhcOptions V.normal lbi bi clbi odir + version = compilerVersion (compiler lbi) + in return $ renderGhcOptions version opts _ -> error "no library" ---------------------------------------------------------------- |