Quick Start for developers
http://hackage.haskell.org/trac/ghc/wiki/Building/Hacking
-
+
This section on the wiki will get you up and running with a
- serviceable build tree in no time:
-
+ serviceable build tree in no time.
+
+ Don't skip this! By default, GHC builds with all optimizations
+ and profiling; most hackers will want a quicker build, so creating
+ a mk/build.mk file and knowing how to rebuild only parts of GHC is
+ very important.
+
This is part of the "Building GHC" section of the wiki, which
has more detailed information on GHC's build system should you
need it.
AC_MSG_CHECKING([Setting up $2, $3, $4 and $5])
case $$1 in
i386-apple-darwin)
- # By default, gcc on OS X will generate SSE
- # instructions, which need things 16-byte aligned,
- # but we don't 16-byte align things. Thus drop
- # back to generic i686 compatibility. Trac #2983.
- $2="$$2 -march=i686 -m32"
- $3="$$3 -march=i686 -m32"
+ $2="$$2 -m32"
+ $3="$$3 -m32"
$4="$$4 -arch i386"
- $5="$$5 -march=i686 -m32"
+ $5="$$5 -m32"
;;
x86_64-apple-darwin)
$2="$$2 -m64"
use Cwd;
my %required_tag;
+my $validate;
$required_tag{"-"} = 1;
+$validate = 0;
while ($#ARGV ne -1) {
my $arg = shift @ARGV;
if ($arg =~ /^--required-tag=(.*)/) {
$required_tag{$1} = 1;
}
+ elsif ($arg =~ /^--validate$/) {
+ $validate = 1;
+ }
else {
die "Bad arg: $arg";
}
}
+{
+ 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: $?";
}
}
+if ($validate eq 0 && ! -f "mk/build.mk") {
+ print <<EOF;
+
+WARNING: You don't have a mk/build.mk file.
+
+By default a standard GHC build will be done, which uses optimisation
+and builds the profiling libraries. This will take a long time, so may
+not be what you want if you are developing GHC or the libraries, rather
+than simply building it to use it.
+
+For information on creating a mk/build.mk file, please see:
+ http://hackage.haskell.org/trac/ghc/wiki/Building/Using#Buildconfiguration
+
+EOF
+}
+
#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
-------------------------------------------------
-- 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))
-------------------------------------------------
-- 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
-- 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)
| CmmRegOff CmmReg Int
-- CmmRegOff reg i
-- ** is shorthand only, meaning **
- -- CmmMachOp (MO_S_Add rep (CmmReg reg) (CmmLit (CmmInt i rep)))
- -- where rep = cmmRegType reg
+ -- CmmMachOp (MO_Add rep) [x, CmmLit (CmmInt (fromIntegral i) rep)]
+ -- where rep = typeWidth (cmmRegType reg)
instance Eq CmmExpr where -- Equality ignores the types
CmmLit l1 == CmmLit l2 = l1==l2
cmmExprType (CmmMachOp op args) = machOpResultType op (map cmmExprType args)
cmmExprType (CmmRegOff reg _) = cmmRegType reg
cmmExprType (CmmStackSlot _ _) = bWord -- an address
+-- Careful though: what is stored at the stack slot may be bigger than
+-- an address
cmmLitType :: CmmLit -> CmmType
cmmLitType (CmmInt _ width) = cmmBits width
import Constants
import FastString
-import Control.Monad
import Data.Maybe
-- -----------------------------------------------------------------------------
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
-- 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,
, copyInOflow, copyInSlot, copyOutOflow, copyOutSlot
-- Reexport of needed Cmm stuff
, Convention(..), ForeignConvention(..), ForeignTarget(..)
- , CmmStackInfo(..), CmmTopInfo(..), CmmGraph(..)
+ , CmmStackInfo(..), CmmTopInfo(..), CmmGraph, GenCmmGraph(..)
, Cmm, CmmTop
)
where
import Control.Monad
import StaticFlags (opt_Fuel)
import UniqSupply
-#ifdef DEBUG
import Panic
-#endif
import Compiler.Hoopl
import Compiler.Hoopl.GHC (getFuel, setFuel)
oneLessFuel :: OptimizationFuel -> OptimizationFuel
unlimitedFuel :: OptimizationFuel
-#ifdef DEBUG
newtype OptimizationFuel = OptimizationFuel Int
deriving Show
anyFuelLeft (OptimizationFuel f) = f > 0
oneLessFuel (OptimizationFuel f) = ASSERT (f > 0) (OptimizationFuel (f - 1))
unlimitedFuel = OptimizationFuel infiniteFuel
-#else
--- type OptimizationFuel = State# () -- would like this, but it won't work
-data OptimizationFuel = OptimizationFuel
- deriving Show
-tankFilledTo _ = OptimizationFuel
-amountOfFuel _ = maxBound
-
-anyFuelLeft _ = True
-oneLessFuel _ = OptimizationFuel
-unlimitedFuel = OptimizationFuel
-#endif
data FuelState = FuelState { fs_fuel :: OptimizationFuel, fs_lastpass :: String }
newtype FuelUniqSM a = FUSM { unFUSM :: FuelState -> UniqSM (a, FuelState) }
-- For backwards compatibility: user code may refer to this
-- label for calling hs_add_root().
- ; emitSimpleProc (mkPlainModuleInitLabel this_mod) $ return ()
+ ; emitData Data $ [ CmmDataLabel (mkPlainModuleInitLabel this_mod) ]
; whenC (this_mod == mainModIs dflags) $
emitSimpleProc (mkPlainModuleInitLabel rOOT_MAIN) $ return ()
import MkGraph
import CmmExpr
+import CmmDecl
import CLabel
import PprCmm
; initCostCentres cost_centre_info
-- For backwards compatibility: user code may refer to this
-- label for calling hs_add_root().
- ; emitSimpleProc (mkPlainModuleInitLabel this_mod) $ emptyAGraph
+ ; emitData Data $ [ CmmDataLabel (mkPlainModuleInitLabel this_mod) ]
}
---------------------------------------------------------------
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
++ (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
link_info <- getLinkInfo dflags dep_packages
mkExtraCObj dflags (showSDoc (vcat [rts_opts_enabled,
extra_rts_opts,
- link_opts link_info]))
+ link_opts link_info]
+ <> char '\n')) -- final newline, to
+ -- keep gcc happy
+
where
mk_rts_opts_enabled val
= vcat [text "#include \"Rts.h\"",
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
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
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
-----------------------------------------------------------------------------
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
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
-- 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
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 = []
-- 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
initDynFlags, -- DynFlags -> IO DynFlags
getOpts, -- DynFlags -> (DynFlags -> [a]) -> [a]
- getVerbFlag,
+ getVerbFlags,
updOptLevel,
setTmpDir,
setPackageName,
-- | 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,
-- add back conflict edges from other nodes to this one
map_conflict
= foldUniqSet
- (adjustUFM (\n -> n { nodeConflicts = addOneToUniqSet (nodeConflicts n) k}))
+ (adjustUFM_C (\n -> n { nodeConflicts = addOneToUniqSet (nodeConflicts n) k}))
(graphMap graph)
(nodeConflicts node)
-- add back coalesce edges from other nodes to this one
map_coalesce
= foldUniqSet
- (adjustUFM (\n -> n { nodeCoalesce = addOneToUniqSet (nodeCoalesce n) k}))
+ (adjustUFM_C (\n -> n { nodeCoalesce = addOneToUniqSet (nodeCoalesce n) k}))
map_conflict
(nodeCoalesce node)
else node -- panic "GraphOps.freezeNode: edge to freeze wasn't in the coalesce set"
-- If the edge isn't actually in the coelesce set then just ignore it.
- fm2 = foldUniqSet (adjustUFM (freezeEdge k)) fm1
+ fm2 = foldUniqSet (adjustUFM_C (freezeEdge k)) fm1
$ nodeCoalesce node
in fm2
setColor u color
= graphMapModify
- $ adjustUFM
+ $ adjustUFM_C
(\n -> n { nodeColor = Just color })
u
map
k def
-{-# INLINE adjustUFM #-}
-adjustUFM
+-- Argument order different from UniqFM's adjustUFM
+{-# INLINE adjustUFM_C #-}
+adjustUFM_C
:: Uniquable k
=> (a -> a)
-> k -> UniqFM a -> UniqFM a
-adjustUFM f k map
+adjustUFM_C f k map
= case lookupUFM map k of
Nothing -> map
Just a -> addToUFM map k (f a)
addListToUFM,addListToUFM_C,
addToUFM_Directly,
addListToUFM_Directly,
+ adjustUFM,
+ adjustUFM_Directly,
delFromUFM,
delFromUFM_Directly,
delListFromUFM,
lookupUFM, lookupUFM_Directly,
lookupWithDefaultUFM, lookupWithDefaultUFM_Directly,
eltsUFM, keysUFM, splitUFM,
- ufmToList
+ ufmToList,
+ joinUFM
) where
import Unique ( Uniquable(..), Unique, getKey )
import Outputable
+import Compiler.Hoopl hiding (Unique)
+
import qualified Data.IntMap as M
\end{code}
-> UniqFM elt -> [(key,elt)]
-> UniqFM elt
+adjustUFM :: Uniquable key => (elt -> elt) -> UniqFM elt -> key -> UniqFM elt
+adjustUFM_Directly :: (elt -> elt) -> UniqFM elt -> Unique -> UniqFM elt
+
delFromUFM :: Uniquable key => UniqFM elt -> key -> UniqFM elt
delListFromUFM :: Uniquable key => UniqFM elt -> [key] -> UniqFM elt
delFromUFM_Directly :: UniqFM elt -> Unique -> UniqFM elt
UFM (M.insertWith (\_new old -> exi v old) (getKey $ getUnique k) (new v) m)
addListToUFM_C f = foldl (\m (k, v) -> addToUFM_C f m k v)
+adjustUFM f (UFM m) k = UFM (M.adjust f (getKey $ getUnique k) m)
+adjustUFM_Directly f (UFM m) u = UFM (M.adjust f (getKey u) m)
+
delFromUFM (UFM m) k = UFM (M.delete (getKey $ getUnique k) m)
delListFromUFM = foldl delFromUFM
delFromUFM_Directly (UFM m) u = UFM (M.delete (getKey u) m)
eltsUFM (UFM m) = M.elems m
ufmToList (UFM m) = map (\(k, v) -> (getUnique k, v)) $ M.toList m
+-- Hoopl
+joinUFM :: JoinFun v -> JoinFun (UniqFM v)
+joinUFM eltJoin l (OldFact old) (NewFact new) = foldUFM_Directly add (NoChange, old) new
+ where add k new_v (ch, joinmap) =
+ case lookupUFM_Directly joinmap k of
+ Nothing -> (SomeChange, addToUFM_Directly joinmap k new_v)
+ Just old_v -> case eltJoin l (OldFact old_v) (NewFact new_v) of
+ (SomeChange, v') -> (SomeChange, addToUFM_Directly joinmap k v')
+ (NoChange, _) -> (ch, joinmap)
+
\end{code}
%************************************************************************
</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>
<entry>dynamic</entry>
<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>
</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>
<indexterm><primary><option>-fwarn-name-shadowing</option></primary></indexterm>
# -----------------------------------------------------------------------------
# Building dependencies
+include rules/dependencies.mk
include rules/build-dependencies.mk
include rules/include-dependencies.mk
/* 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 */
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 */
};
* 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;
}
}
static void
-freeHashList(HashList *hl)
+freeHashList (HashTable *table, HashList *hl)
{
- hl->next = freeList;
- freeList = hl;
+ hl->next = table->freeList;
+ table->freeList = hl;
}
void
segment = bucket / HSEGSIZE;
index = bucket % HSEGSIZE;
- hl = allocHashList();
+ hl = allocHashList(table);
hl->key = key;
hl->data = data;
table->dir[segment][index] = hl->next;
else
prev->next = hl->next;
- freeHashList(hl);
+ freeHashList(table,hl);
table->kcount--;
return hl->data;
}
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;
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);
}
table->mask2 = 2 * HSEGSIZE - 1;
table->kcount = 0;
table->bcount = HSEGSIZE;
+ table->freeList = NULL;
+ table->chunks = NULL;
table->hash = hash;
table->compare = compare;
void
exitHashTable(void)
{
- struct chunkList *cl;
-
- while ((cl = chunks) != NULL) {
- chunks = cl->next;
- stgFree(cl->chunk);
- stgFree(cl);
- }
+ /* nothing to do */
}
#include <sys/wait.h>
#endif
-#if defined(linux_HOST_OS ) || defined(freebsd_HOST_OS) || \
- defined(dragonfly_HOST_OS) || defined(netbsd_HOST_OS ) || \
- defined(openbsd_HOST_OS ) || \
- ( defined(darwin_HOST_OS ) && !defined(powerpc_HOST_ARCH) ) || \
- defined(kfreebsdgnu_HOST_OS)
-/* Don't use mmap on powerpc-apple-darwin as mmap doesn't support
+#if !defined(powerpc_HOST_ARCH) && \
+ ( defined(linux_HOST_OS ) || defined(freebsd_HOST_OS) || \
+ defined(dragonfly_HOST_OS) || defined(netbsd_HOST_OS ) || \
+ defined(openbsd_HOST_OS ) || defined(darwin_HOST_OS ) || \
+ defined(kfreebsdgnu_HOST_OS) )
+/* Don't use mmap on powerpc_HOST_ARCH as mmap doesn't support
* reallocating but we need to allocate jump islands just after each
* object images. Otherwise relative branches to jump islands can fail
* due to 24-bits displacement overflow.
ocFlushInstructionCache( ObjectCode *oc )
{
/* The main object code */
- ocFlushInstructionCacheFrom(oc->image + oc->misalignment, oc->fileSize);
+ ocFlushInstructionCacheFrom(oc->image
+#ifdef darwin_HOST_OS
+ + oc->misalignment
+#endif
+ , oc->fileSize);
/* Jump Islands */
ocFlushInstructionCacheFrom(oc->symbol_extras, sizeof(SymbolExtra) * oc->n_symbol_extras);
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;
+ }
}
/* -----------------------------------------------------------------------------
mut = 0;
for (i = 0; i < n_capabilities; i++) {
mut += countOccupied(capabilities[i].mut_lists[g]);
+
+ // Add the pinned object block.
+ bd = capabilities[i].pinned_object_block;
+ if (bd != NULL) {
+ gen_live += bd->free - bd->start;
+ gen_blocks += bd->blocks;
+ }
+
+ gen_live += gcThreadLiveWords(i,g);
gen_live += gcThreadLiveWords(i,g);
gen_blocks += gcThreadLiveBlocks(i,g);
}
endif
-$(eval $(call build-dependencies,rts,dist,1))
-$(eval $(call include-dependencies,rts,dist,1))
+$(eval $(call dependencies,rts,dist,1))
$(rts_dist_depfile_c_asm) : libffi/dist-install/build/ffi.h $(DTRACEPROBES_H)
// update the max size of older generations after a major GC
resize_generations();
- // Start a new pinned_object_block
- for (n = 0; n < n_capabilities; n++) {
- capabilities[n].pinned_object_block = NULL;
- }
-
// Free the mark stack.
if (mark_stack_top_bd != NULL) {
debugTrace(DEBUG_gc, "mark stack: %d blocks",
// zero the scavenged static object list
if (major_gc) {
nat i;
- for (i = 0; i < n_gc_threads; i++) {
- zero_static_object_list(gc_threads[i]->scavenged_static_objects);
+ if (n_gc_threads == 1) {
+ zero_static_object_list(gct->scavenged_static_objects);
+ } else {
+ for (i = 0; i < n_gc_threads; i++) {
+ zero_static_object_list(gc_threads[i]->scavenged_static_objects);
+ }
}
}
for (i = 0; i < n_capabilities; i++) {
markBlocks(nurseries[i].blocks);
+ markBlocks(capabilities[i].pinned_object_block);
}
#ifdef PROFILING
for (i = 0; i < n_capabilities; i++) {
ASSERT(countBlocks(nurseries[i].blocks) == nurseries[i].n_blocks);
nursery_blocks += nurseries[i].n_blocks;
+ if (capabilities[i].pinned_object_block != NULL) {
+ nursery_blocks += capabilities[i].pinned_object_block->blocks;
+ }
}
retainer_blocks = 0;
// If we don't have a block of pinned objects yet, or the current
// one isn't large enough to hold the new object, allocate a new one.
if (bd == NULL || (bd->free + n) > (bd->start + BLOCK_SIZE_W)) {
+ // The pinned_object_block remains attached to the capability
+ // until it is full, even if a GC occurs. We want this
+ // behaviour because otherwise the unallocated portion of the
+ // block would be forever slop, and under certain workloads
+ // (allocating a few ByteStrings per GC) we accumulate a lot
+ // of slop.
+ //
+ // So, the pinned_object_block is initially marked
+ // BF_EVACUATED so the GC won't touch it. When it is full,
+ // we place it on the large_objects list, and at the start of
+ // the next GC the BF_EVACUATED flag will be cleared, and the
+ // block will be promoted as usual (if anything in it is
+ // live).
ACQUIRE_SM_LOCK;
- cap->pinned_object_block = bd = allocBlock();
- dbl_link_onto(bd, &g0->large_objects);
- g0->n_large_blocks++;
+ if (bd != NULL) {
+ dbl_link_onto(bd, &g0->large_objects);
+ g0->n_large_blocks++;
+ g0->n_new_large_words += bd->free - bd->start;
+ }
+ cap->pinned_object_block = bd = allocBlock();
RELEASE_SM_LOCK;
initBdescr(bd, g0, g0);
- bd->flags = BF_PINNED | BF_LARGE;
+ bd->flags = BF_PINNED | BF_LARGE | BF_EVACUATED;
bd->free = bd->start;
}
- g0->n_new_large_words += n;
p = bd->free;
bd->free += n;
return p;
$(call c-sources,$1,$2)
$(call includes-sources,$1,$2)
-# --- DEPENDENCIES
-# We always have the dependency rules available, as we need to know
-# how to build hsc2hs's dependency file in phase 0
-$(call build-dependencies,$1,$2,$3)
-ifneq "$(phase)" "0"
-# From phase 1 we actually include the dependency files for the
-# bootstrapping stuff
-ifeq "$3" "0"
-$(call include-dependencies,$1,$2,$3)
-else ifeq "$(phase)" "final"
-# In the final phase, we also include the dependency files for
-# everything else
-$(call include-dependencies,$1,$2,$3)
-endif
-endif
+$(call dependencies,$1,$2,$3)
# Now generate all the build rules for each way in this directory:
$$(foreach way,$$($1_$2_WAYS),$$(eval \
endif
endif
-# --- DEPENDENCIES
-# We always have the dependency rules available, as we need to know
-# how to build hsc2hs's dependency file in phase 0
-$(call build-dependencies,$1,$2,$3)
-ifneq "$(phase)" "0"
-# From phase 1 we actually include the dependency files for the
-# bootstrapping stuff
-ifeq "$3" "0"
-$(call include-dependencies,$1,$2,$3)
-else ifeq "$(phase)" "final"
-# In the final phase, we also include the dependency files for
-# everything else
-$(call include-dependencies,$1,$2,$3)
-endif
-endif
+$(call dependencies,$1,$2,$3)
endef
--- /dev/null
+# -----------------------------------------------------------------------------
+#
+# (c) 2009 The University of Glasgow
+#
+# This file is part of the GHC build system.
+#
+# To understand how the build system works and how to modify it, see
+# http://hackage.haskell.org/trac/ghc/wiki/Building/Architecture
+# http://hackage.haskell.org/trac/ghc/wiki/Building/Modifying
+#
+# -----------------------------------------------------------------------------
+
+define dependencies
+$(call trace, dependencies($1,$2,$3))
+$(call profStart, dependencies($1,$2,$3))
+# $1 = dir
+# $2 = distdir
+# $3 = GHC stage to use (0 == bootstrapping compiler)
+
+# We always have the dependency rules available, as we need to know
+# how to build hsc2hs's dependency file in phase 0
+$(call build-dependencies,$1,$2,$3)
+
+ifneq "$(phase)" "0"
+# From phase 1 we actually include the dependency files for the
+# bootstrapping stuff
+ifeq "$3" "0"
+$(call include-dependencies,$1,$2,$3)
+else ifeq "$(phase)" "final"
+# In the final phase, we also include the dependency files for
+# everything else
+$(call include-dependencies,$1,$2,$3)
+endif
+endif
+
+$(call profEnd, dependencies($1,$2,$3))
+endef
+
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.
}
}
-sub repoexists {
- my ($scm, $localpath) = @_;
-
- if ($scm eq "darcs") {
- -d "$localpath/_darcs";
- }
- else {
- -d "$localpath/.git";
- }
-}
-
sub scmall {
my $command = shift;
my $path;
my $wd_before = getcwd;
- my @scm_args;
-
my $pwd;
my @args;
} else {
$branch_name = shift;
}
- } elsif ($command eq 'new' || $command eq 'fetch') {
+ } elsif ($command eq 'new') {
if (@_ < 1) {
$branch_name = 'origin';
} else {
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");
- # git fails if there is nothing to commit, so ignore failures
- $ignore_failure = 1;
+ if ($tags{$tag} == 0) {
+ next;
}
- elsif ($command =~ /^(?:pus|push)$/) {
- @scm_args = "push";
- }
- elsif ($command =~ /^(?:pul|pull)$/) {
- @scm_args = "pull";
- # Q: should we append the -a argument for darcs repos?
- }
- elsif ($command =~ /^(?:g|ge|get)$/) {
- # Skip any repositories we have not included the tag for
- if (not defined($tags{$tag})) {
- next;
- }
-
- if (-d $localpath) {
- warning("$localpath already present; omitting") if $localpath ne ".";
- next;
+
+ if (-d $localpath) {
+ warning("$localpath already present; omitting")
+ if $localpath ne ".";
+ if ($scm eq "git") {
+ scm ($localpath, $scm, "config", "core.ignorecase", "true");
}
-
+ next;
+ }
+
+ # Note that we use "." as the path, as $localpath
+ # doesn't exist yet.
+ if ($scm eq "darcs") {
# The first time round the loop, default the get-mode
- if ($scm eq "darcs" && not defined($get_mode)) {
+ if (not defined($get_mode)) {
warning("adding --partial, to override use --complete");
$get_mode = "--partial";
}
-
- # The only command that doesn't need a repo
- $local_repo_unnecessary = 1;
-
- if ($scm eq "darcs") {
- # Note: we can only use the get-mode with darcs for now
- @scm_args = ("get", $get_mode, $path, $localpath);
- }
- else {
- @scm_args = ("clone", $path, $localpath);
- }
+ scm (".", $scm, "get", $get_mode, $path, $localpath, @args);
}
- elsif ($command =~ /^(?:s|se|sen|send)$/) {
- @scm_args = (($scm eq "darcs" and "send")
- or ($scm eq "git" and "send-email"));
- $want_remote_repo = 1;
+ else {
+ scm (".", $scm, "clone", $path, $localpath, @args);
+ scm ($localpath, $scm, "config", "core.ignorecase", "true");
}
- elsif ($command =~ /^fetch$/) {
- @scm_args = ("fetch", "$branch_name");
+ next;
+ }
+
+ if (-d "$localpath/_darcs") {
+ if (-d "$localpath/.git") {
+ die "Found both _darcs and .git in $localpath";
}
- elsif ($command =~ /^new$/) {
- @scm_args = ("log", "$branch_name..");
+ else {
+ $scm = "darcs";
}
- elsif ($command =~ /^remote$/) {
- if ($subcommand eq 'add') {
- @scm_args = ("remote", "add", $branch_name, $path);
- } elsif ($subcommand eq 'rm') {
- @scm_args = ("remote", "rm", $branch_name);
- } elsif ($subcommand eq 'set-url') {
- @scm_args = ("remote", "set-url", $branch_name, $path);
- }
+ }
+ else {
+ if (-d "$localpath/.git") {
+ $scm = "git";
}
- elsif ($command =~ /^grep$/) {
- @scm_args = ("grep");
- # Hack around 'git grep' failing if there are no matches
- $ignore_failure = 1;
+ elsif ($tag eq "") {
+ die "Required repo $localpath is missing";
}
- elsif ($command =~ /^reset$/) {
- @scm_args = "reset";
+ else {
+ message "== $localpath repo not present; skipping";
}
- elsif ($command =~ /^config$/) {
- @scm_args = "config";
+ }
+
+ # Work out the arguments we should give to the SCM
+ if ($command =~ /^(?:w|wh|wha|what|whats|whatsn|whatsne|whatsnew|status)$/) {
+ if ($scm eq "darcs") {
+ $command = "whatsnew";
}
- else {
- die "Unknown command: $command";
+ elsif ($scm eq "git") {
+ $command = "status";
}
-
- # Actually execute the command
- if (repoexists ($scm, $localpath)) {
- if ($want_remote_repo) {
- if ($scm eq "darcs") {
- scm (".", $scm, @scm_args, @args, "--repodir=$localpath", $path);
- } else {
- # git pull doesn't like to be used with --work-dir
- # I couldn't find an alternative to chdir() here
- scm ($localpath, $scm, @scm_args, @args, $path, "master");
- }
- } else {
- # git status *must* be used with --work-dir, if we don't chdir() to the dir
- scm ($localpath, $scm, @scm_args, @args);
- }
+ else {
+ die "Unknown scm";
}
- elsif ($local_repo_unnecessary) {
- # Don't bother to change directory in this case
- scm (".", $scm, @scm_args, @args);
+
+ # Hack around 'darcs whatsnew' failing if there are no changes
+ $ignore_failure = 1;
+ scm ($localpath, $scm, $command, @args);
+ }
+ elsif ($command =~ /^commit$/) {
+ # git fails if there is nothing to commit, so ignore failures
+ $ignore_failure = 1;
+ scm ($localpath, $scm, "commit", @args);
+ }
+ elsif ($command =~ /^(?:pus|push)$/) {
+ scm ($localpath, $scm, "push", @args);
+ }
+ elsif ($command =~ /^(?:pul|pull)$/) {
+ scm ($localpath, $scm, "pull", @args);
+ }
+ elsif ($command =~ /^(?:s|se|sen|send)$/) {
+ if ($scm eq "darcs") {
+ $command = "send";
}
- elsif ($tag eq "") {
- message "== Required repo $localpath is missing! Skipping";
+ elsif ($scm eq "git") {
+ $command = "send-email";
}
else {
- message "== $localpath repo not present; skipping";
+ die "Unknown scm";
+ }
+ scm ($localpath, $scm, $command, @args);
+ }
+ elsif ($command =~ /^fetch$/) {
+ scm ($localpath, $scm, "fetch", @args);
+ }
+ elsif ($command =~ /^new$/) {
+ my @scm_args = ("log", "$branch_name..");
+ scm ($localpath, $scm, @scm_args, @args);
+ }
+ elsif ($command =~ /^remote$/) {
+ my @scm_args;
+ if ($subcommand eq 'add') {
+ @scm_args = ("remote", "add", $branch_name, $path);
+ } elsif ($subcommand eq 'rm') {
+ @scm_args = ("remote", "rm", $branch_name);
+ } elsif ($subcommand eq 'set-url') {
+ @scm_args = ("remote", "set-url", $branch_name, $path);
}
+ scm ($localpath, $scm, @scm_args, @args);
+ }
+ elsif ($command =~ /^grep$/) {
+ # Hack around 'git grep' failing if there are no matches
+ $ignore_failure = 1;
+ scm ($localpath, $scm, "grep", @args)
+ unless $scm eq "darcs";
+ }
+ elsif ($command =~ /^reset$/) {
+ scm ($localpath, $scm, "reset", @args)
+ unless $scm eq "darcs";
+ }
+ elsif ($command =~ /^config$/) {
+ scm ($localpath, $scm, "config", @args)
+ unless $scm eq "darcs";
+ }
+ else {
+ die "Unknown command: $command";
+ }
}
}
}
# --<tag> says we grab the libs tagged 'tag' with
# 'get'. It has no effect on the other commands.
- elsif ($arg =~ m/^--/) {
- $arg =~ s/^--//;
- $tags{$arg} = 1;
+ elsif ($arg =~ m/^--no-(.*)$/) {
+ $tags{$1} = 0;
+ }
+ elsif ($arg =~ m/^--(.*)$/) {
+ $tags{$1} = 1;
}
else {
unshift @_, $arg;
import System.FilePath
main :: IO ()
-main = do args <- getArgs
+main = do hSetBuffering stdout LineBuffering
+ args <- getArgs
case args of
"hscolour" : distDir : dir : args' ->
runHsColour distDir dir args'
INSTDIR=`cygpath -m "$INSTDIR"`
fi
- /usr/bin/perl -w boot --required-tag=dph
+ /usr/bin/perl -w boot --validate --required-tag=dph
./configure --prefix="$INSTDIR" $config_args
fi
projects / ghc-hetmet.git / commitdiff