From: Simon Peyton Jones Date: Wed, 20 Apr 2011 10:32:05 +0000 (+0100) Subject: Merge branch 'master' into ghc-new-co X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=39bb1bd24f56d1abd9961813d9cd94b61c9d4c78;hp=fdf8656855d26105ff36bdd24d41827b05037b91 Merge branch 'master' into ghc-new-co --- diff --git a/HACKING b/HACKING index be9eec2..8ceff18 100644 --- a/HACKING +++ b/HACKING @@ -21,10 +21,15 @@ The GHC Developer's Wiki 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. diff --git a/aclocal.m4 b/aclocal.m4 index e09bda8..0e72d22 100644 --- a/aclocal.m4 +++ b/aclocal.m4 @@ -94,14 +94,10 @@ AC_DEFUN([FPTOOLS_SET_C_LD_FLAGS], 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" diff --git a/boot b/boot index ae57381..66bff3e 100755 --- a/boot +++ b/boot @@ -5,8 +5,10 @@ use strict; use Cwd; my %required_tag; +my $validate; $required_tag{"-"} = 1; +$validate = 0; while ($#ARGV ne -1) { my $arg = shift @ARGV; @@ -14,11 +16,32 @@ while ($#ARGV ne -1) { 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 = ; + close FILE; + + if ($string =~ /\r/) { + print STDERR < 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) diff --git a/compiler/cmm/CmmExpr.hs b/compiler/cmm/CmmExpr.hs index 3ae2996..55a5b73 100644 --- a/compiler/cmm/CmmExpr.hs +++ b/compiler/cmm/CmmExpr.hs @@ -42,8 +42,8 @@ data CmmExpr | 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 @@ -124,6 +124,8 @@ cmmExprType (CmmReg reg) = cmmRegType reg 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 diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs index 95b1eef..c14ad65 100644 --- a/compiler/cmm/CmmLint.hs +++ b/compiler/cmm/CmmLint.hs @@ -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, diff --git a/compiler/cmm/MkGraph.hs b/compiler/cmm/MkGraph.hs index 69b481b..c9e422f 100644 --- a/compiler/cmm/MkGraph.hs +++ b/compiler/cmm/MkGraph.hs @@ -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 diff --git a/compiler/cmm/OptimizationFuel.hs b/compiler/cmm/OptimizationFuel.hs index 8d3a06b..f624c1c 100644 --- a/compiler/cmm/OptimizationFuel.hs +++ b/compiler/cmm/OptimizationFuel.hs @@ -21,9 +21,7 @@ import Data.IORef import Control.Monad import StaticFlags (opt_Fuel) import UniqSupply -#ifdef DEBUG import Panic -#endif import Compiler.Hoopl import Compiler.Hoopl.GHC (getFuel, setFuel) @@ -53,7 +51,6 @@ anyFuelLeft :: OptimizationFuel -> Bool oneLessFuel :: OptimizationFuel -> OptimizationFuel unlimitedFuel :: OptimizationFuel -#ifdef DEBUG newtype OptimizationFuel = OptimizationFuel Int deriving Show @@ -63,17 +60,6 @@ amountOfFuel (OptimizationFuel f) = f 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) } diff --git a/compiler/codeGen/CodeGen.lhs b/compiler/codeGen/CodeGen.lhs index 81a65f7..7a7bf48 100644 --- a/compiler/codeGen/CodeGen.lhs +++ b/compiler/codeGen/CodeGen.lhs @@ -105,7 +105,7 @@ mkModuleInit dflags cost_centre_info this_mod hpc_info -- 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 () diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs index fa3dcfe..2bfe187 100644 --- a/compiler/codeGen/StgCmm.hs +++ b/compiler/codeGen/StgCmm.hs @@ -25,6 +25,7 @@ import StgCmmTicky import MkGraph import CmmExpr +import CmmDecl import CLabel import PprCmm @@ -181,7 +182,7 @@ mkModuleInit cost_centre_info this_mod hpc_info ; 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) ] } --------------------------------------------------------------- diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 61486fc..9dd9cc7 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -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 @@ -1433,7 +1434,10 @@ mkExtraObjToLinkIntoBinary dflags dep_packages = do 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\"", @@ -1574,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 @@ -1652,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 @@ -1768,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 @@ -1813,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 @@ -1873,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 @@ -1909,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 @@ -1942,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 = [] @@ -1962,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 diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index a387610..294a165 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -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, diff --git a/compiler/utils/GraphOps.hs b/compiler/utils/GraphOps.hs index 388b968..1fa4199 100644 --- a/compiler/utils/GraphOps.hs +++ b/compiler/utils/GraphOps.hs @@ -61,14 +61,14 @@ addNode k node graph -- 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) @@ -434,7 +434,7 @@ freezeNode k 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 @@ -604,7 +604,7 @@ setColor setColor u color = graphMapModify - $ adjustUFM + $ adjustUFM_C (\n -> n { nodeColor = Just color }) u @@ -621,13 +621,14 @@ adjustWithDefaultUFM f def k map 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) diff --git a/compiler/utils/UniqFM.lhs b/compiler/utils/UniqFM.lhs index 31d1e87..7302b02 100644 --- a/compiler/utils/UniqFM.lhs +++ b/compiler/utils/UniqFM.lhs @@ -36,6 +36,8 @@ module UniqFM ( addListToUFM,addListToUFM_C, addToUFM_Directly, addListToUFM_Directly, + adjustUFM, + adjustUFM_Directly, delFromUFM, delFromUFM_Directly, delListFromUFM, @@ -53,12 +55,15 @@ module UniqFM ( 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} @@ -103,6 +108,9 @@ addListToUFM_C :: Uniquable key => (elt -> elt -> elt) -> 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 @@ -175,6 +183,9 @@ addToUFM_Acc exi new (UFM m) k v = 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) @@ -207,6 +218,16 @@ keysUFM (UFM m) = map getUnique $ M.keys 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} %************************************************************************ diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml index e0940ae..26ab9eb 100644 --- a/docs/users_guide/flags.xml +++ b/docs/users_guide/flags.xml @@ -1180,6 +1180,13 @@ + + warn about polymorphic local bindings without signatures + dynamic + + + + warn when names are shadowed dynamic diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml index a5fba51..9ea3332 100644 --- a/docs/users_guide/glasgow_exts.xml +++ b/docs/users_guide/glasgow_exts.xml @@ -5884,7 +5884,7 @@ type variables, in the annotated expression. For example: f = runST ( (op >>= \(x :: STRef s Int) -> g x) :: forall s. ST s Bool ) -Here, the type signature forall a. ST s Bool brings the +Here, the type signature forall s. ST s Bool brings the type variable s into scope, in the annotated expression (op >>= \(x :: STRef s Int) -> g x). diff --git a/docs/users_guide/using.xml b/docs/users_guide/using.xml index 8b08d9d..115c290 100644 --- a/docs/users_guide/using.xml +++ b/docs/users_guide/using.xml @@ -1373,6 +1373,20 @@ module M where + : + + + type signatures, missing + + If you use the + 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. + + + + : diff --git a/ghc.mk b/ghc.mk index 863ddc2..0f58876 100644 --- a/ghc.mk +++ b/ghc.mk @@ -227,6 +227,7 @@ include rules/package-config.mk # ----------------------------------------------------------------------------- # Building dependencies +include rules/dependencies.mk include rules/build-dependencies.mk include rules/include-dependencies.mk diff --git a/rts/Hash.c b/rts/Hash.c index 09d0a06..9c9b2bc 100644 --- a/rts/Hash.c +++ b/rts/Hash.c @@ -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 */ } diff --git a/rts/Linker.c b/rts/Linker.c index 5285ec6..c840857 100644 --- a/rts/Linker.c +++ b/rts/Linker.c @@ -70,12 +70,12 @@ #include #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. @@ -2572,7 +2572,11 @@ static void 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); diff --git a/rts/Stats.c b/rts/Stats.c index 159a909..fa38472 100644 --- a/rts/Stats.c +++ b/rts/Stats.c @@ -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; + } } /* ----------------------------------------------------------------------------- @@ -798,6 +804,15 @@ statDescribeGens(void) 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); } diff --git a/rts/ghc.mk b/rts/ghc.mk index df68bc5..53bb72c 100644 --- a/rts/ghc.mk +++ b/rts/ghc.mk @@ -456,8 +456,7 @@ rts_dist_MKDEPENDC_OPTS += -Irts/dist/build 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) diff --git a/rts/sm/GC.c b/rts/sm/GC.c index d0dd44d..3036140 100644 --- a/rts/sm/GC.c +++ b/rts/sm/GC.c @@ -597,11 +597,6 @@ GarbageCollect (rtsBool force_major_gc, // 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", @@ -643,8 +638,12 @@ GarbageCollect (rtsBool force_major_gc, // 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); + } } } diff --git a/rts/sm/Sanity.c b/rts/sm/Sanity.c index 8ebb9a2..0ec552c 100644 --- a/rts/sm/Sanity.c +++ b/rts/sm/Sanity.c @@ -789,6 +789,7 @@ findMemoryLeak (void) for (i = 0; i < n_capabilities; i++) { markBlocks(nurseries[i].blocks); + markBlocks(capabilities[i].pinned_object_block); } #ifdef PROFILING @@ -880,6 +881,9 @@ memInventory (rtsBool show) 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; diff --git a/rts/sm/Storage.c b/rts/sm/Storage.c index ae3433a..f8a9e55 100644 --- a/rts/sm/Storage.c +++ b/rts/sm/Storage.c @@ -657,17 +657,32 @@ allocatePinned (Capability *cap, lnat n) // 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; diff --git a/rules/build-package.mk b/rules/build-package.mk index ac0a8ee..c735e51 100644 --- a/rules/build-package.mk +++ b/rules/build-package.mk @@ -100,21 +100,7 @@ $(call hs-sources,$1,$2) $(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 \ diff --git a/rules/build-prog.mk b/rules/build-prog.mk index 5c352a2..c39f947 100644 --- a/rules/build-prog.mk +++ b/rules/build-prog.mk @@ -188,20 +188,6 @@ INSTALL_BINS += $1/$2/build/tmp/$$($1_$2_PROG) 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 diff --git a/rules/dependencies.mk b/rules/dependencies.mk new file mode 100644 index 0000000..42605a5 --- /dev/null +++ b/rules/dependencies.mk @@ -0,0 +1,38 @@ +# ----------------------------------------------------------------------------- +# +# (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 + diff --git a/sync-all b/sync-all index 02ac521..06c183a 100755 --- a/sync-all +++ b/sync-all @@ -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"); - # 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"; + } } } @@ -484,9 +488,11 @@ sub main { } # -- 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; diff --git a/utils/ghc-cabal/Main.hs b/utils/ghc-cabal/Main.hs index 72a5010..d64c224 100644 --- a/utils/ghc-cabal/Main.hs +++ b/utils/ghc-cabal/Main.hs @@ -28,7 +28,8 @@ import System.Exit 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' diff --git a/validate b/validate index 8d6e2c3..b1ae14f 100755 --- a/validate +++ b/validate @@ -73,7 +73,7 @@ if [ $no_clean -eq 0 ]; then 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