Commit 4b089dba authored by Ian Lynagh's avatar Ian Lynagh
Browse files

Merge branch 'master' of darcs.haskell.org:/srv/darcs//ghc

parents 041d1bcf 9fb12e14
...@@ -74,6 +74,7 @@ _darcs/ ...@@ -74,6 +74,7 @@ _darcs/
/libraries/stm/ /libraries/stm/
/libraries/template-haskell/ /libraries/template-haskell/
/libraries/terminfo/ /libraries/terminfo/
/libraries/transformers
/libraries/unix/ /libraries/unix/
/libraries/utf8-string/ /libraries/utf8-string/
/libraries/vector/ /libraries/vector/
......
...@@ -419,6 +419,7 @@ $(eval $(call addPackage,Cabal/Cabal)) ...@@ -419,6 +419,7 @@ $(eval $(call addPackage,Cabal/Cabal))
$(eval $(call addPackage,binary)) $(eval $(call addPackage,binary))
$(eval $(call addPackage,bin-package-db)) $(eval $(call addPackage,bin-package-db))
$(eval $(call addPackage,hoopl)) $(eval $(call addPackage,hoopl))
$(eval $(call addPackage,transformers))
$(eval $(call addPackage,mtl)) $(eval $(call addPackage,mtl))
$(eval $(call addPackage,utf8-string)) $(eval $(call addPackage,utf8-string))
$(eval $(call addPackage,xhtml)) $(eval $(call addPackage,xhtml))
......
...@@ -14,11 +14,9 @@ ...@@ -14,11 +14,9 @@
#ifndef RTS_FILELOCK_H #ifndef RTS_FILELOCK_H
#define RTS_FILELOCK_H #define RTS_FILELOCK_H
#ifdef HAVE_SYS_TYPES_H #include "Stg.h"
#include <sys/types.h>
#endif
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); int unlockFile(int fd);
#endif /* RTS_FILELOCK_H */ #endif /* RTS_FILELOCK_H */
...@@ -95,9 +95,15 @@ libraries/hoopl/src/Compiler/Hoopl/XUtil_HC_OPTS += -Wwarn ...@@ -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/Pointed_HC_OPTS += -Wwarn
libraries/hoopl/src/Compiler/Hoopl/Passes/Dominator_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 # primitive has a warning about deprecated use of GHC.IOBase
libraries/primitive_dist-install_EXTRA_HC_OPTS += -Wwarn 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 # vector has some unused match warnings
libraries/vector_dist-install_EXTRA_HC_OPTS += -Wwarn libraries/vector_dist-install_EXTRA_HC_OPTS += -Wwarn
......
...@@ -70,6 +70,7 @@ libraries/pretty - packages/pretty.git ...@@ -70,6 +70,7 @@ libraries/pretty - packages/pretty.git
libraries/process - packages/process.git git libraries/process - packages/process.git git
libraries/template-haskell - packages/template-haskell.git git libraries/template-haskell - packages/template-haskell.git git
libraries/terminfo - packages/terminfo.git git libraries/terminfo - packages/terminfo.git git
libraries/transformers - packages/transformers.git git
libraries/unix - packages/unix.git git libraries/unix - packages/unix.git git
libraries/utf8-string - packages/utf8-string.git git libraries/utf8-string - packages/utf8-string.git git
libraries/Win32 - packages/Win32.git git libraries/Win32 - packages/Win32.git git
......
...@@ -14,13 +14,12 @@ ...@@ -14,13 +14,12 @@
#include "RtsUtils.h" #include "RtsUtils.h"
#include <sys/types.h> #include <sys/types.h>
#include <sys/stat.h>
#include <unistd.h> #include <unistd.h>
#include <errno.h> #include <errno.h>
typedef struct { typedef struct {
dev_t device; StgWord64 device;
ino_t inode; StgWord64 inode;
int readers; // >0 : readers, <0 : writers int readers; // >0 : readers, <0 : writers
} Lock; } Lock;
...@@ -45,8 +44,8 @@ static int cmpLocks(StgWord w1, StgWord w2) ...@@ -45,8 +44,8 @@ static int cmpLocks(StgWord w1, StgWord w2)
static int hashLock(HashTable *table, StgWord w) static int hashLock(HashTable *table, StgWord w)
{ {
Lock *l = (Lock *)w; Lock *l = (Lock *)w;
// Just xor the dev_t with the ino_t, hope this is good enough. // Just xor all 32-bit words of inode and device, hope this is good enough.
return hashWord(table, (StgWord)l->inode ^ (StgWord)l->device); return hashWord(table, l->inode ^ (l->inode >> 32) ^ l->device ^ (l->device >> 32));
} }
void void
...@@ -76,7 +75,7 @@ freeFileLocking(void) ...@@ -76,7 +75,7 @@ freeFileLocking(void)
} }
int 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; Lock key, *lock;
......
...@@ -11,6 +11,9 @@ ...@@ -11,6 +11,9 @@
#include "BeginPrivate.h" #include "BeginPrivate.h"
void initializeTimer (void);
StgWord64 getMonotonicNSec (void);
Time getProcessCPUTime (void); Time getProcessCPUTime (void);
Time getThreadCPUTime (void); Time getThreadCPUTime (void);
Time getProcessElapsedTime (void); Time getProcessElapsedTime (void);
......
...@@ -304,8 +304,6 @@ typedef struct _RtsSymbolVal { ...@@ -304,8 +304,6 @@ typedef struct _RtsSymbolVal {
SymI_HasProto(__hscore_get_saved_termios) \ SymI_HasProto(__hscore_get_saved_termios) \
SymI_HasProto(__hscore_set_saved_termios) \ SymI_HasProto(__hscore_set_saved_termios) \
SymI_HasProto(shutdownHaskellAndSignal) \ SymI_HasProto(shutdownHaskellAndSignal) \
SymI_HasProto(lockFile) \
SymI_HasProto(unlockFile) \
SymI_HasProto(signal_handlers) \ SymI_HasProto(signal_handlers) \
SymI_HasProto(stg_sig_install) \ SymI_HasProto(stg_sig_install) \
SymI_HasProto(rtsTimerSignal) \ SymI_HasProto(rtsTimerSignal) \
...@@ -1283,6 +1281,9 @@ typedef struct _RtsSymbolVal { ...@@ -1283,6 +1281,9 @@ typedef struct _RtsSymbolVal {
SymI_HasProto(n_capabilities) \ SymI_HasProto(n_capabilities) \
SymI_HasProto(stg_traceCcszh) \ SymI_HasProto(stg_traceCcszh) \
SymI_HasProto(stg_traceEventzh) \ SymI_HasProto(stg_traceEventzh) \
SymI_HasProto(getMonotonicNSec) \
SymI_HasProto(lockFile) \
SymI_HasProto(unlockFile) \
RTS_USER_SIGNALS_SYMBOLS \ RTS_USER_SIGNALS_SYMBOLS \
RTS_INTCHAR_SYMBOLS RTS_INTCHAR_SYMBOLS
......
...@@ -35,6 +35,7 @@ ...@@ -35,6 +35,7 @@
#include "Profiling.h" #include "Profiling.h"
#include "Timer.h" #include "Timer.h"
#include "Globals.h" #include "Globals.h"
#include "FileLock.h"
void exitLinker( void ); // there is no Linker.h file to include void exitLinker( void ); // there is no Linker.h file to include
#if defined(RTS_GTK_FRONTPANEL) #if defined(RTS_GTK_FRONTPANEL)
...@@ -52,7 +53,6 @@ void exitLinker( void ); // there is no Linker.h file to include ...@@ -52,7 +53,6 @@ void exitLinker( void ); // there is no Linker.h file to include
#if !defined(mingw32_HOST_OS) #if !defined(mingw32_HOST_OS)
#include "posix/TTY.h" #include "posix/TTY.h"
#include "posix/FileLock.h"
#endif #endif
#ifdef HAVE_UNISTD_H #ifdef HAVE_UNISTD_H
...@@ -128,6 +128,9 @@ hs_init_ghc(int *argc, char **argv[], RtsConfig rts_config) ...@@ -128,6 +128,9 @@ hs_init_ghc(int *argc, char **argv[], RtsConfig rts_config)
/* Initialise the stats department, phase 0 */ /* Initialise the stats department, phase 0 */
initStats0(); initStats0();
/* Initialize system timer before starting to collect stats */
initializeTimer();
/* Next we do is grab the start time...just in case we're /* Next we do is grab the start time...just in case we're
* collecting timing statistics. * collecting timing statistics.
*/ */
...@@ -212,9 +215,7 @@ hs_init_ghc(int *argc, char **argv[], RtsConfig rts_config) ...@@ -212,9 +215,7 @@ hs_init_ghc(int *argc, char **argv[], RtsConfig rts_config)
initGlobalStore(); initGlobalStore();
/* initialise file locking, if necessary */ /* initialise file locking, if necessary */
#if !defined(mingw32_HOST_OS)
initFileLocking(); initFileLocking();
#endif
#if defined(DEBUG) #if defined(DEBUG)
/* initialise thread label table (tso->char*) */ /* initialise thread label table (tso->char*) */
...@@ -373,9 +374,7 @@ hs_exit_(rtsBool wait_foreign) ...@@ -373,9 +374,7 @@ hs_exit_(rtsBool wait_foreign)
exitLinker(); exitLinker();
/* free file locking tables, if necessary */ /* free file locking tables, if necessary */
#if !defined(mingw32_HOST_OS)
freeFileLocking(); freeFileLocking();
#endif
/* free the stable pointer table */ /* free the stable pointer table */
exitStablePtrTable(); exitStablePtrTable();
......
...@@ -33,6 +33,19 @@ ...@@ -33,6 +33,19 @@
// we'll implement getProcessCPUTime() and getProcessElapsedTime() // we'll implement getProcessCPUTime() and getProcessElapsedTime()
// separately, using getrusage() and gettimeofday() respectively // 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) Time getProcessCPUTime(void)
{ {
#if !defined(BE_CONSERVATIVE) && defined(HAVE_CLOCK_GETTIME) && defined (_SC_CPUTIME) && defined(CLOCK_PROCESS_CPUTIME_ID) && defined(HAVE_SYSCONF) #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) ...@@ -64,32 +77,31 @@ Time getProcessCPUTime(void)
} }
} }
Time getProcessElapsedTime(void) StgWord64 getMonotonicNSec(void)
{ {
#ifdef HAVE_CLOCK_GETTIME #ifdef HAVE_CLOCK_GETTIME
struct timespec ts; struct timespec ts;
clock_gettime(CLOCK_ID, &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) #elif defined(darwin_HOST_OS)
uint64_t time = mach_absolute_time(); uint64_t time = mach_absolute_time();
static double scaling_factor = 0.0; return (double)time * timer_scaling_factor_ns;
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);
#else #else
struct timeval tv; struct timeval tv;
gettimeofday(&tv, (struct timezone *) NULL); 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 #endif
} }
Time getProcessElapsedTime(void)
{
return NSToTime(getMonotonicNSec());
}
void getProcessTimes(Time *user, Time *elapsed) void getProcessTimes(Time *user, Time *elapsed)
{ {
*user = getProcessCPUTime(); *user = getProcessCPUTime();
......
...@@ -47,37 +47,57 @@ getProcessCPUTime(void) ...@@ -47,37 +47,57 @@ getProcessCPUTime(void)
return fileTimeToRtsTime(userTime); return fileTimeToRtsTime(userTime);
} }
// getProcessElapsedTime relies on QueryPerformanceFrequency // Number of ticks per second used by the QueryPerformanceFrequency
// which should be available on any Windows computer thay you // implementaiton, represented by a 64-bit union type.
// would want to run Haskell on. Satnam Singh, 5 July 2010. 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 Time
getProcessElapsedTime(void) getProcessElapsedTime(void)
{ {
// frequency represents the number of ticks per second return NSToTime(getMonotonicNSec());
// 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) ;
} }
Time Time
......
...@@ -769,6 +769,42 @@ EOF ...@@ -769,6 +769,42 @@ EOF
chdir($pwd); 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; $? = $ec;
} }
......
...@@ -19,6 +19,7 @@ import Distribution.Verbosity ...@@ -19,6 +19,7 @@ import Distribution.Verbosity
import qualified Distribution.InstalledPackageInfo as Installed import qualified Distribution.InstalledPackageInfo as Installed
import qualified Distribution.Simple.PackageIndex as PackageIndex import qualified Distribution.Simple.PackageIndex as PackageIndex
import Control.Monad
import Data.List import Data.List
import Data.Maybe import Data.Maybe
import System.IO import System.IO
...@@ -184,36 +185,20 @@ doInstall ghc ghcpkg strip topdir directory distDir ...@@ -184,36 +185,20 @@ doInstall ghc ghcpkg strip topdir directory distDir
htmldir = toPathTemplate "$docdir" htmldir = toPathTemplate "$docdir"
} }
progs = withPrograms lbi progs = withPrograms lbi
ghcProg = ConfiguredProgram {
programId = programName ghcProgram,
programVersion = Nothing,
programDefaultArgs = ["-B" ++ topdir],
programOverrideArgs = [],
programLocation = UserSpecified ghc
}
ghcpkgconf = topdir </> "package.conf.d" ghcpkgconf = topdir </> "package.conf.d"
ghcPkgProg = ConfiguredProgram { ghcProgram' = ghcProgram {
programId = programName ghcPkgProgram, programPostConf = \_ _ -> return ["-B" ++ topdir],
programVersion = Nothing, programFindLocation = \_ -> return (Just ghc) }
programDefaultArgs = ["--global-conf", ghcPkgProgram' = ghcPkgProgram {
ghcpkgconf] programPostConf = \_ _ -> return $ ["--global-conf", ghcpkgconf]
++ if not (null myDestDir) ++ ["--force" | not (null myDestDir) ],
then ["--force"] programFindLocation = \_ -> return (Just ghcpkg) }
else [], stripProgram' = stripProgram {
programOverrideArgs = [], programFindLocation = \_ -> return (Just strip) }
programLocation = UserSpecified ghcpkg configurePrograms ps conf = foldM (flip (configureProgram verbosity)) conf ps
}
stripProg = ConfiguredProgram { progs' <- configurePrograms [ghcProgram', ghcPkgProgram', stripProgram'] progs
programId = programName stripProgram, let Just ghcPkgProg = lookupProgram ghcPkgProgram' progs'
programVersion = Nothing,
programDefaultArgs = [],
programOverrideArgs = [],
programLocation = UserSpecified strip
}
progs' = updateProgram ghcProg
$ updateProgram ghcPkgProg
$ updateProgram stripProg
progs
instInfos <- dump verbosity ghcPkgProg GlobalPackageDB instInfos <- dump verbosity ghcPkgProg GlobalPackageDB
let installedPkgs' = PackageIndex.fromList instInfos let installedPkgs' = PackageIndex.fromList instInfos
let mlc = libraryConfig lbi let mlc = libraryConfig lbi
...@@ -404,4 +389,3 @@ generate config_args distdir directory ...@@ -404,4 +389,3 @@ generate config_args distdir directory
| otherwise = return ("\'" ++ s ++ "\'") | otherwise = return ("\'" ++ s ++ "\'")
boolToYesNo True = "YES" boolToYesNo True = "YES"
boolToYesNo False = "NO" boolToYesNo False = "NO"
...@@ -19,10 +19,13 @@ import MonadUtils ( liftIO ) ...@@ -19,10 +19,13 @@ import MonadUtils ( liftIO )
import SrcLoc import SrcLoc
-- Every GHC comes with Cabal anyways, so this is not a bad new dependency -- 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.Configure ( getPersistBuildConfig )
import Distribution.Simple.Compiler ( compilerVersion )
import Distribution.Simple.Program.GHC ( renderGhcOptions )
import Distribution.PackageDescription ( library, libBuildInfo ) 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 Control.Monad hiding (mapM)
import System.Environment import System.Environment
...@@ -184,8 +187,9 @@ flagsFromCabal distPref = do ...@@ -184,8 +187,9 @@ flagsFromCabal distPref = do
(Just lib, Just clbi) -> (Just lib, Just clbi) ->
let bi = libBuildInfo lib let bi = libBuildInfo lib
odir = buildDir lbi odir = buildDir lbi
opts = ghcOptions lbi bi clbi odir opts = componentGhcOptions V.normal lbi bi clbi odir
in return opts version = compilerVersion (compiler lbi)
in return $ renderGhcOptions version opts
_ -> error "no library" _ -> error "no library"
---------------------------------------------------------------- ----------------------------------------------------------------
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment