Commit 3a11d63b authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

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

parents 2691104b 44fbccd6
......@@ -24,6 +24,24 @@ while ($#ARGV ne -1) {
}
}
{
local $/ = undef;
open FILE, "packages" or die "Couldn't open file: $!";
binmode FILE;
my $string = <FILE>;
close FILE;
if ($string =~ /\r/) {
print STDERR <<EOF;
Found ^M in packages.
Perhaps you need to run
git config --global core.autocrlf false
and re-check out the tree?
EOF
exit 1;
}
}
# Create libraries/*/{ghc.mk,GNUmakefile}
system("/usr/bin/perl", "-w", "boot-pkgs") == 0
or die "Running boot-pkgs failed: $?";
......
......@@ -9,10 +9,11 @@
#endif
module Cmm
( CmmGraph(..), CmmBlock
( CmmGraph, GenCmmGraph(..), CmmBlock
, CmmStackInfo(..), CmmTopInfo(..), Cmm, CmmTop
, CmmReplGraph, CmmFwdRewrite, CmmBwdRewrite
, modifyGraph
, lastNode, replaceLastNode, insertBetween
, ofBlockMap, toBlockMap, insertBlock
, ofBlockList, toBlockList, bodyToBlockList
......@@ -41,7 +42,8 @@ import Panic
-------------------------------------------------
-- CmmBlock, CmmGraph and Cmm
data CmmGraph = CmmGraph { g_entry :: BlockId, g_graph :: Graph CmmNode C C }
type CmmGraph = GenCmmGraph CmmNode
data GenCmmGraph n = CmmGraph { g_entry :: BlockId, g_graph :: Graph n C C }
type CmmBlock = Block CmmNode C C
type CmmReplGraph e x = FuelUniqSM (Maybe (Graph CmmNode e x))
......@@ -56,6 +58,9 @@ type CmmTop = GenCmmTop CmmStatic CmmTopInfo CmmGraph
-------------------------------------------------
-- Manipulating CmmGraphs
modifyGraph :: (Graph n C C -> Graph n' C C) -> GenCmmGraph n -> GenCmmGraph n'
modifyGraph f g = CmmGraph {g_entry=g_entry g, g_graph=f (g_graph g)}
toBlockMap :: CmmGraph -> LabelMap CmmBlock
toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body
......@@ -150,26 +155,26 @@ insertBetween b ms succId = insert $ lastNode b
-- Running dataflow analysis and/or rewrites
-- Constructing forward and backward analysis-only pass
analFwd :: Monad m => DataflowLattice f -> FwdTransfer CmmNode f -> FwdPass m CmmNode f
analBwd :: Monad m => DataflowLattice f -> BwdTransfer CmmNode f -> BwdPass m CmmNode f
analFwd :: Monad m => DataflowLattice f -> FwdTransfer n f -> FwdPass m n f
analBwd :: Monad m => DataflowLattice f -> BwdTransfer n f -> BwdPass m n f
analFwd lat xfer = analRewFwd lat xfer noFwdRewrite
analBwd lat xfer = analRewBwd lat xfer noBwdRewrite
-- Constructing forward and backward analysis + rewrite pass
analRewFwd :: Monad m => DataflowLattice f -> FwdTransfer CmmNode f -> FwdRewrite m CmmNode f -> FwdPass m CmmNode f
analRewBwd :: Monad m => DataflowLattice f -> BwdTransfer CmmNode f -> BwdRewrite m CmmNode f -> BwdPass m CmmNode f
analRewFwd :: Monad m => DataflowLattice f -> FwdTransfer n f -> FwdRewrite m n f -> FwdPass m n f
analRewBwd :: Monad m => DataflowLattice f -> BwdTransfer n f -> BwdRewrite m n f -> BwdPass m n f
analRewFwd lat xfer rew = FwdPass {fp_lattice = lat, fp_transfer = xfer, fp_rewrite = rew}
analRewBwd lat xfer rew = BwdPass {bp_lattice = lat, bp_transfer = xfer, bp_rewrite = rew}
-- Running forward and backward dataflow analysis + optional rewrite
dataflowPassFwd :: CmmGraph -> [(BlockId, f)] -> FwdPass FuelUniqSM CmmNode f -> FuelUniqSM (CmmGraph, BlockEnv f)
dataflowPassFwd :: NonLocal n => GenCmmGraph n -> [(BlockId, f)] -> FwdPass FuelUniqSM n f -> FuelUniqSM (GenCmmGraph n, BlockEnv f)
dataflowPassFwd (CmmGraph {g_entry=entry, g_graph=graph}) facts fwd = do
(graph, facts, NothingO) <- analyzeAndRewriteFwd fwd (JustC [entry]) graph (mkFactBase (fp_lattice fwd) facts)
return (CmmGraph {g_entry=entry, g_graph=graph}, facts)
dataflowPassBwd :: CmmGraph -> [(BlockId, f)] -> BwdPass FuelUniqSM CmmNode f -> FuelUniqSM (CmmGraph, BlockEnv f)
dataflowPassBwd :: NonLocal n => GenCmmGraph n -> [(BlockId, f)] -> BwdPass FuelUniqSM n f -> FuelUniqSM (GenCmmGraph n, BlockEnv f)
dataflowPassBwd (CmmGraph {g_entry=entry, g_graph=graph}) facts bwd = do
(graph, facts, NothingO) <- analyzeAndRewriteBwd bwd (JustC [entry]) graph (mkFactBase (bp_lattice bwd) facts)
return (CmmGraph {g_entry=entry, g_graph=graph}, facts)
......@@ -24,7 +24,6 @@ import OldPprCmm()
import Constants
import FastString
import Control.Monad
import Data.Maybe
-- -----------------------------------------------------------------------------
......@@ -70,8 +69,10 @@ lintCmmBlock labels (BasicBlock id stmts)
lintCmmExpr :: CmmExpr -> CmmLint CmmType
lintCmmExpr (CmmLoad expr rep) = do
_ <- lintCmmExpr expr
when (widthInBytes (typeWidth rep) >= wORD_SIZE) $
cmmCheckWordAddress expr
-- Disabled, if we have the inlining phase before the lint phase,
-- we can have funny offsets due to pointer tagging. -- EZY
-- when (widthInBytes (typeWidth rep) >= wORD_SIZE) $
-- cmmCheckWordAddress expr
return rep
lintCmmExpr expr@(CmmMachOp op args) = do
tys <- mapM lintCmmExpr args
......@@ -99,14 +100,14 @@ isOffsetOp _ = False
-- This expression should be an address from which a word can be loaded:
-- check for funny-looking sub-word offsets.
cmmCheckWordAddress :: CmmExpr -> CmmLint ()
cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
_cmmCheckWordAddress :: CmmExpr -> CmmLint ()
_cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
| isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
= cmmLintDubiousWordOffset e
cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
_cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
| isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
= cmmLintDubiousWordOffset e
cmmCheckWordAddress _
_cmmCheckWordAddress _
= return ()
-- No warnings for unaligned arithmetic with the node register,
......
......@@ -24,7 +24,7 @@ module MkGraph
, copyInOflow, copyInSlot, copyOutOflow, copyOutSlot
-- Reexport of needed Cmm stuff
, Convention(..), ForeignConvention(..), ForeignTarget(..)
, CmmStackInfo(..), CmmTopInfo(..), CmmGraph(..)
, CmmStackInfo(..), CmmTopInfo(..), CmmGraph, GenCmmGraph(..)
, Cmm, CmmTop
)
where
......
......@@ -1031,7 +1031,7 @@ runPhase cc_phase input_fn dflags
gcc_extra_viac_flags <- io $ getExtraViaCOpts dflags
let pic_c_flags = picCCOpts dflags
let verb = getVerbFlag dflags
let verbFlags = getVerbFlags dflags
-- cc-options are not passed when compiling .hc files. Our
-- hc code doesn't not #include any header files anyway, so these
......@@ -1118,7 +1118,8 @@ runPhase cc_phase input_fn dflags
++ (if hcc
then gcc_extra_viac_flags ++ more_hcc_opts
else [])
++ [ verb, "-S", "-Wimplicit", cc_opt ]
++ verbFlags
++ [ "-S", "-Wimplicit", cc_opt ]
++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ]
#ifdef darwin_TARGET_OS
++ framework_paths
......@@ -1577,7 +1578,7 @@ getHCFilePackages filename =
linkBinary :: DynFlags -> [FilePath] -> [PackageId] -> IO ()
linkBinary dflags o_files dep_packages = do
let verb = getVerbFlag dflags
let verbFlags = getVerbFlags dflags
output_fn = exeFileName dflags
-- get the full list of packages to link with, by combining the
......@@ -1655,10 +1656,10 @@ linkBinary dflags o_files dep_packages = do
let md_c_flags = machdepCCOpts dflags
SysTools.runLink dflags (
[ SysTools.Option verb
, SysTools.Option "-o"
, SysTools.FileOption "" output_fn
]
map SysTools.Option verbFlags
++ [ SysTools.Option "-o"
, SysTools.FileOption "" output_fn
]
++ map SysTools.Option (
md_c_flags
......@@ -1771,7 +1772,7 @@ maybeCreateManifest dflags exe_filename = do
linkDynLib :: DynFlags -> [String] -> [PackageId] -> IO ()
linkDynLib dflags o_files dep_packages = do
let verb = getVerbFlag dflags
let verbFlags = getVerbFlags dflags
let o_file = outputFile dflags
pkgs <- getPreloadPackagesAnd dflags dep_packages
......@@ -1816,15 +1817,15 @@ linkDynLib dflags o_files dep_packages = do
-----------------------------------------------------------------------------
let output_fn = case o_file of { Just s -> s; Nothing -> "HSdll.dll"; }
SysTools.runLink dflags
([ SysTools.Option verb
, SysTools.Option "-o"
, SysTools.FileOption "" output_fn
, SysTools.Option "-shared"
] ++
[ SysTools.FileOption "-Wl,--out-implib=" (output_fn ++ ".a")
| dopt Opt_SharedImplib dflags
]
SysTools.runLink dflags (
map SysTools.Option verbFlags
++ [ SysTools.Option "-o"
, SysTools.FileOption "" output_fn
, SysTools.Option "-shared"
] ++
[ SysTools.FileOption "-Wl,--out-implib=" (output_fn ++ ".a")
| dopt Opt_SharedImplib dflags
]
++ map (SysTools.FileOption "") o_files
++ map SysTools.Option (
md_c_flags
......@@ -1876,12 +1877,12 @@ linkDynLib dflags o_files dep_packages = do
Nothing -> do
pwd <- getCurrentDirectory
return $ pwd `combine` output_fn
SysTools.runLink dflags
([ SysTools.Option verb
, SysTools.Option "-dynamiclib"
, SysTools.Option "-o"
, SysTools.FileOption "" output_fn
]
SysTools.runLink dflags (
map SysTools.Option verbFlags
++ [ SysTools.Option "-dynamiclib"
, SysTools.Option "-o"
, SysTools.FileOption "" output_fn
]
++ map SysTools.Option (
md_c_flags
++ o_files
......@@ -1912,11 +1913,11 @@ linkDynLib dflags o_files dep_packages = do
-- non-PIC intra-package-relocations
["-Wl,-Bsymbolic"]
SysTools.runLink dflags
([ SysTools.Option verb
, SysTools.Option "-o"
, SysTools.FileOption "" output_fn
]
SysTools.runLink dflags (
map SysTools.Option verbFlags
++ [ SysTools.Option "-o"
, SysTools.FileOption "" output_fn
]
++ map SysTools.Option (
md_c_flags
++ o_files
......@@ -1945,7 +1946,7 @@ doCpp dflags raw include_cc_opts input_fn output_fn = do
let include_paths = foldr (\ x xs -> "-I" : x : xs) []
(cmdline_include_paths ++ pkg_include_dirs)
let verb = getVerbFlag dflags
let verbFlags = getVerbFlags dflags
let cc_opts
| not include_cc_opts = []
......@@ -1965,7 +1966,7 @@ doCpp dflags raw include_cc_opts input_fn output_fn = do
-- remember, in code we *compile*, the HOST is the same our TARGET,
-- and BUILD is the same as our HOST.
cpp_prog ([SysTools.Option verb]
cpp_prog ( map SysTools.Option verbFlags
++ map SysTools.Option include_paths
++ map SysTools.Option hsSourceCppOpts
++ map SysTools.Option target_defs
......
......@@ -40,7 +40,7 @@ module DynFlags (
initDynFlags, -- DynFlags -> IO DynFlags
getOpts, -- DynFlags -> (DynFlags -> [a]) -> [a]
getVerbFlag,
getVerbFlags,
updOptLevel,
setTmpDir,
setPackageName,
......@@ -873,10 +873,10 @@ getOpts dflags opts = reverse (opts dflags)
-- | Gets the verbosity flag for the current verbosity level. This is fed to
-- other tools, so GHC-specific verbosity flags like @-ddump-most@ are not included
getVerbFlag :: DynFlags -> String
getVerbFlag dflags
| verbosity dflags >= 3 = "-v"
| otherwise = ""
getVerbFlags :: DynFlags -> [String]
getVerbFlags dflags
| verbosity dflags >= 4 = ["-v"]
| otherwise = []
setObjectDir, setHiDir, setStubDir, setOutputDir, setDylibInstallName,
setObjectSuf, setHiSuf, setHcSuf, parseDynLibLoaderMode,
......
......@@ -1179,6 +1179,13 @@
<entry><option>-fno-warn-missing-signatures</option></entry>
</row>
<row>
<entry><option>-fwarn-missing-local-sigs</option></entry>
<entry>warn about polymorphic local bindings without signatures</entry>
<entry>dynamic</entry>
<entry><option>-fno-warn-missing-local-sigs</option></entry>
</row>
<row>
<entry><option>-fwarn-name-shadowing</option></entry>
<entry>warn when names are shadowed</entry>
......
......@@ -5884,7 +5884,7 @@ type variables, in the annotated expression. For example:
<programlisting>
f = runST ( (op >>= \(x :: STRef s Int) -> g x) :: forall s. ST s Bool )
</programlisting>
Here, the type signature <literal>forall a. ST s Bool</literal> brings the
Here, the type signature <literal>forall s. ST s Bool</literal> brings the
type variable <literal>s</literal> into scope, in the annotated expression
<literal>(op >>= \(x :: STRef s Int) -> g x)</literal>.
</para>
......
......@@ -1372,6 +1372,20 @@ module M where
</listitem>
</varlistentry>
<varlistentry>
<term><option>-fwarn-missing-local-sigs</option>:</term>
<listitem>
<indexterm><primary><option>-fwarn-missing-local-sigs</option></primary></indexterm>
<indexterm><primary>type signatures, missing</primary></indexterm>
<para>If you use the
<option>-fwarn-missing-local-sigs</option> flag GHC will warn
you about any polymorphic local bindings. As part of
the warning GHC also reports the inferred type. The
option is off by default.</para>
</listitem>
</varlistentry>
<varlistentry>
<term><option>-fwarn-name-shadowing</option>:</term>
<listitem>
......
......@@ -27,13 +27,16 @@
/* Linked list of (key, data) pairs for separate chaining */
struct hashlist {
typedef struct hashlist {
StgWord key;
void *data;
struct hashlist *next; /* Next cell in bucket chain (same hash value) */
};
} HashList;
typedef struct hashlist HashList;
typedef struct chunklist {
HashList *chunk;
struct chunklist *next;
} HashListChunk;
struct hashtable {
int split; /* Next bucket to split when expanding */
......@@ -43,7 +46,9 @@ struct hashtable {
int kcount; /* Number of keys */
int bcount; /* Number of buckets */
HashList **dir[HDIRSIZE]; /* Directory of segments */
HashFunction *hash; /* hash function */
HashList *freeList; /* free list of HashLists */
HashListChunk *chunks;
HashFunction *hash; /* hash function */
CompareFunction *compare; /* key comparison function */
};
......@@ -207,30 +212,23 @@ lookupHashTable(HashTable *table, StgWord key)
* no effort to actually return the space to the malloc arena.
* -------------------------------------------------------------------------- */
static HashList *freeList = NULL;
static struct chunkList {
void *chunk;
struct chunkList *next;
} *chunks;
static HashList *
allocHashList(void)
allocHashList (HashTable *table)
{
HashList *hl, *p;
struct chunkList *cl;
HashListChunk *cl;
if ((hl = freeList) != NULL) {
freeList = hl->next;
if ((hl = table->freeList) != NULL) {
table->freeList = hl->next;
} else {
hl = stgMallocBytes(HCHUNK * sizeof(HashList), "allocHashList");
cl = stgMallocBytes(sizeof (*cl), "allocHashList: chunkList");
cl->chunk = hl;
cl->next = chunks;
chunks = cl;
cl->chunk = hl;
cl->next = table->chunks;
table->chunks = cl;
freeList = hl + 1;
for (p = freeList; p < hl + HCHUNK - 1; p++)
table->freeList = hl + 1;
for (p = table->freeList; p < hl + HCHUNK - 1; p++)
p->next = p + 1;
p->next = NULL;
}
......@@ -238,10 +236,10 @@ allocHashList(void)
}
static void
freeHashList(HashList *hl)
freeHashList (HashTable *table, HashList *hl)
{
hl->next = freeList;
freeList = hl;
hl->next = table->freeList;
table->freeList = hl;
}
void
......@@ -264,7 +262,7 @@ insertHashTable(HashTable *table, StgWord key, void *data)
segment = bucket / HSEGSIZE;
index = bucket % HSEGSIZE;
hl = allocHashList();
hl = allocHashList(table);
hl->key = key;
hl->data = data;
......@@ -292,7 +290,7 @@ removeHashTable(HashTable *table, StgWord key, void *data)
table->dir[segment][index] = hl->next;
else
prev->next = hl->next;
freeHashList(hl);
freeHashList(table,hl);
table->kcount--;
return hl->data;
}
......@@ -317,6 +315,7 @@ freeHashTable(HashTable *table, void (*freeDataFun)(void *) )
long index;
HashList *hl;
HashList *next;
HashListChunk *cl, *cl_next;
/* The last bucket with something in it is table->max + table->split - 1 */
segment = (table->max + table->split - 1) / HSEGSIZE;
......@@ -328,14 +327,18 @@ freeHashTable(HashTable *table, void (*freeDataFun)(void *) )
next = hl->next;
if (freeDataFun != NULL)
(*freeDataFun)(hl->data);
freeHashList(hl);
}
}
index--;
}
stgFree(table->dir[segment]);
segment--;
index = HSEGSIZE - 1;
}
for (cl = table->chunks; cl != NULL; cl = cl_next) {
cl_next = cl->next;
stgFree(cl->chunk);
stgFree(cl);
}
stgFree(table);
}
......@@ -363,6 +366,8 @@ allocHashTable_(HashFunction *hash, CompareFunction *compare)
table->mask2 = 2 * HSEGSIZE - 1;
table->kcount = 0;
table->bcount = HSEGSIZE;
table->freeList = NULL;
table->chunks = NULL;
table->hash = hash;
table->compare = compare;
......@@ -385,11 +390,5 @@ allocStrHashTable(void)
void
exitHashTable(void)
{
struct chunkList *cl;
while ((cl = chunks) != NULL) {
chunks = cl->next;
stgFree(cl->chunk);
stgFree(cl);
}
/* nothing to do */
}
......@@ -753,12 +753,18 @@ stat_exit(int alloc)
statsClose();
}
if (GC_coll_cpu)
if (GC_coll_cpu) {
stgFree(GC_coll_cpu);
GC_coll_cpu = NULL;
if (GC_coll_elapsed)
GC_coll_cpu = NULL;
}
if (GC_coll_elapsed) {
stgFree(GC_coll_elapsed);
GC_coll_elapsed = NULL;
GC_coll_elapsed = NULL;
}
if (GC_coll_max_pause) {
stgFree(GC_coll_max_pause);
GC_coll_max_pause = NULL;
}
}
/* -----------------------------------------------------------------------------
......
......@@ -65,13 +65,9 @@ my $defaultrepo;
my @packages;
my $verbose = 2;
my $ignore_failure = 0;
my $want_remote_repo = 0;
my $checked_out_flag = 0;
my $get_mode;
# Flags specific to a particular command
my $local_repo_unnecessary = 0;
my %tags;
# Figure out where to get the other repositories from.
......@@ -195,17 +191,6 @@ sub scm {
}
}
sub repoexists {
my ($scm, $localpath) = @_;
if ($scm eq "darcs") {
-d "$localpath/_darcs";
}
else {
-d "$localpath/.git";
}
}
sub scmall {
my $command = shift;
......@@ -221,8 +206,6 @@ sub scmall {
my $path;
my $wd_before = getcwd;
my @scm_args;
my $pwd;
my @args;
......@@ -253,7 +236,7 @@ sub scmall {
} else {
$branch_name = shift;
}
} elsif ($command eq 'new' || $command eq 'fetch') {
} elsif ($command eq 'new') {
if (@_ < 1) {
$branch_name = 'origin';
} else {
......@@ -265,137 +248,158 @@ sub scmall {
for $line (@packages) {
$localpath = $$line{"localpath"};
$tag = $$line{"tag"};
$remotepath = $$line{"remotepath"};
$scm = $$line{"vcs"};
$upstream = $$line{"upstream"};
$localpath = $$line{"localpath"};
$tag = $$line{"tag"};
$remotepath = $$line{"remotepath"};
$scm = $$line{"vcs"};
$upstream = $$line{"upstream"};
# We can't create directories on GitHub, so we translate
# "package/foo" into "package-foo".
if ($is_github_repo) {
$remotepath =~ s/\//-/;
}
# Check the SCM is OK as early as possible
die "Unknown SCM: $scm" if (($scm ne "darcs") and ($scm ne "git"));
# Check the SCM is OK as early as possible
die "Unknown SCM: $scm" if (($scm ne "darcs") and ($scm ne "git"));
# We can't create directories on GitHub, so we translate
# "package/foo" into "package-foo".
if ($is_github_repo) {
$remotepath =~ s/\//-/;
}
# Work out the path for this package in the repo we pulled from
if ($checked_out_tree) {
$path = "$repo_base/$localpath";
}
else {
$path = "$repo_base/$remotepath";
}
# Work out the path for this package in the repo we pulled from
if ($checked_out_tree) {
$path = "$repo_base/$localpath";
}
else {
$path = "$repo_base/$remotepath";
}
# Work out the arguments we should give to the SCM
if ($command =~ /^(?:w|wh|wha|what|whats|whatsn|whatsne|whatsnew|status)$/) {
@scm_args = (($scm eq "darcs" and "whatsnew")
or ($scm eq "git" and "status"));
# Hack around 'darcs whatsnew' failing if there are no changes
$ignore_failure = 1;
if ($command =~ /^(?:g|ge|get)$/) {
# Skip any repositories we have not included the tag for
if (not defined($tags{$tag})) {
$tags{$tag} = 0;
}
elsif ($command =~ /^commit$/) {
@scm_args = ("commit");