From: Ben Lippmeier Date: Wed, 27 Apr 2011 06:40:48 +0000 (+1000) Subject: Merge branch 'master' of /Users/benl/devel/ghc/ghc-head X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=dc2575083cbc8680e15f4eee8956a9487fc56ddc;hp=8fb6e595c16568c4793048bd9671515bd00f0946 Merge branch 'master' of /Users/benl/devel/ghc/ghc-head --- diff --git a/.gitignore b/.gitignore index bbcff22..3e2e7f4 100644 --- a/.gitignore +++ b/.gitignore @@ -7,6 +7,7 @@ *.BAK *.orig *.prof +*.rej *.hi *.hi-boot @@ -30,6 +31,12 @@ config.status configure # ----------------------------------------------------------------------------- +# Ignore any overlapped darcs repos and back up files + +*-darcs-backup* +_darcs/ + +# ----------------------------------------------------------------------------- # sub-repositories /ghc-tarballs/ @@ -79,9 +86,7 @@ configure /bindist-list /bindistprep/ /bindisttest/HelloWorld -/bindisttest/a/ -/bindisttest/install\ dir/ -/bindisttest/output +/bindisttest/ /ch01.html /ch02.html /compiler/cmm/CmmLex.hs @@ -119,8 +124,12 @@ configure /docs/users_guide/users_guide.xml /docs/users_guide/users_guide/ /docs/users_guide/what_glasgow_exts_does.gen.xml +/driver/ghc/dist/ +/driver/haddock/dist/ /driver/ghci/ghc-pkg-inplace /driver/ghci/ghci-inplace +/driver/ghci/dist/ +/driver/ghci/ghci.res /driver/mangler/dist/ghc-asm /driver/mangler/dist/ghc-asm.prl /driver/package.conf @@ -128,7 +137,7 @@ configure /driver/split/dist/ghc-split /driver/split/dist/ghc-split.prl /driver/stamp-pkg-conf-rts -/extra-gcc-opts +/settings /ghc.spec /ghc/ghc-bin.cabal /ghc/stage1/ @@ -150,6 +159,8 @@ configure /libffi/package.conf.inplace /libffi/package.conf.inplace.raw /libffi/stamp* +/libffi/package.conf.install +/libffi/package.conf.install.raw /libraries/bin-package-db/GNUmakefile /libraries/bin-package-db/ghc.mk /libraries/bootstrapping.conf @@ -185,6 +196,8 @@ configure /rts/package.conf.inplace.raw /rts/sm/Evac_thr.c /rts/sm/Scav_thr.c +/rts/package.conf.install +/rts/package.conf.install.raw /stage3.package.conf /testsuite_summary.txt /testlog @@ -218,3 +231,4 @@ configure /utils/runghc/runhaskell /utils/runstdtest/runstdtest /utils/unlit/unlit + diff --git a/aclocal.m4 b/aclocal.m4 index 0e72d22..4b750ef 100644 --- a/aclocal.m4 +++ b/aclocal.m4 @@ -181,8 +181,8 @@ AC_DEFUN([FP_EVAL_STDERR], # -------------------- # XXX # -# $1 = the command to look for -# $2 = the variable to set +# $1 = the variable to set +# $2 = the command to look for # AC_DEFUN([FP_ARG_WITH_PATH_GNU_PROG], [ @@ -646,32 +646,6 @@ fi ])# FP_PROG_AR_NEEDS_RANLIB -# FP_PROG_AR_SUPPORTS_INPUT -# ------------------------- -# Sets the output variable ArSupportsInput to "-input" or "", depending on -# whether ar supports -input flag is supported or not. -AC_DEFUN([FP_PROG_AR_SUPPORTS_INPUT], -[AC_REQUIRE([FP_PROG_AR_IS_GNU]) -AC_REQUIRE([FP_PROG_AR_ARGS]) -AC_CACHE_CHECK([whether $fp_prog_ar_raw supports -input], [fp_cv_prog_ar_supports_input], -[fp_cv_prog_ar_supports_input=no -if test $fp_prog_ar_is_gnu = no; then - rm -f conftest* - touch conftest.lst - if FP_EVAL_STDERR(["$fp_prog_ar_raw" $fp_prog_ar_args conftest.a -input conftest.lst]) >/dev/null; then - test -s conftest.err || fp_cv_prog_ar_supports_input=yes - fi - rm -f conftest* -fi]) -if test $fp_cv_prog_ar_supports_input = yes; then - ArSupportsInput="-input" -else - ArSupportsInput="" -fi -AC_SUBST([ArSupportsInput]) -])# FP_PROG_AR_SUPPORTS_INPUT - - dnl dnl AC_SHEBANG_PERL - can we she-bang perl? dnl @@ -691,38 +665,30 @@ rm -f conftest ])]) -# FP_HAVE_GCC +# FP_GCC_VERSION # ----------- # Extra testing of the result AC_PROG_CC, testing the gcc version no. Sets the -# output variables HaveGcc and GccVersion. -AC_DEFUN([FP_HAVE_GCC], +# output variable GccVersion. +AC_DEFUN([FP_GCC_VERSION], [AC_REQUIRE([AC_PROG_CC]) -if test -z "$GCC"; then - fp_have_gcc=NO -else - fp_have_gcc=YES -fi -if test "$fp_have_gcc" = "NO" -a -d $srcdir/ghc; then +if test -z "$GCC" +then AC_MSG_ERROR([gcc is required]) fi GccLT34= AC_CACHE_CHECK([version of gcc], [fp_cv_gcc_version], -[if test "$fp_have_gcc" = "YES"; then - fp_cv_gcc_version="`$CC -v 2>&1 | grep 'version ' | sed -e 's/.*version [[^0-9]]*\([[0-9.]]*\).*/\1/g'`" - FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-lt], [3.0], - [AC_MSG_ERROR([Need at least gcc version 3.0 (3.4+ recommended)])]) - # See #2770: gcc 2.95 doesn't work any more, apparently. There probably - # isn't a very good reason for that, but for now just make configure - # fail. - FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-lt], [3.4], GccLT34=YES) - else - fp_cv_gcc_version="not-installed" - fi +[ + fp_cv_gcc_version="`$CC -v 2>&1 | grep 'version ' | sed -e 's/.*version [[^0-9]]*\([[0-9.]]*\).*/\1/g'`" + FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-lt], [3.0], + [AC_MSG_ERROR([Need at least gcc version 3.0 (3.4+ recommended)])]) + # See #2770: gcc 2.95 doesn't work any more, apparently. There probably + # isn't a very good reason for that, but for now just make configure + # fail. + FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-lt], [3.4], GccLT34=YES) ]) -AC_SUBST([HaveGcc], [$fp_have_gcc]) AC_SUBST([GccVersion], [$fp_cv_gcc_version]) AC_SUBST(GccLT34) -])# FP_HAVE_GCC +])# FP_GCC_VERSION dnl Small feature test for perl version. Assumes PerlCmd dnl contains path to perl binary. @@ -1094,7 +1060,7 @@ AC_SUBST([GhcPkgCmd]) # integer wrap around. (Trac #952) # AC_DEFUN([FP_GCC_EXTRA_FLAGS], -[AC_REQUIRE([FP_HAVE_GCC]) +[AC_REQUIRE([FP_GCC_VERSION]) AC_CACHE_CHECK([for extra options to pass gcc when compiling via C], [fp_cv_gcc_extra_opts], [fp_cv_gcc_extra_opts= FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-ge], [3.4], @@ -1116,7 +1082,7 @@ if test "$RELEASE" = "NO"; then AC_MSG_RESULT(given $PACKAGE_VERSION) elif test -d .git; then changequote(, )dnl - ver_date=`git log -n 1 --date=short --pretty=format:%ci | sed "s/^.*\([0-9][0-9][0-9][0-9]\)-\([0-9][0-9]\)-\([0-9][0-9]\).*$/\1\2\3/"` + ver_date=`git log -n 1 --date=short --pretty=format:%ci | cut -d ' ' -f 1 | tr -d -` if echo $ver_date | grep '^[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9]$' 2>&1 >/dev/null; then true; else changequote([, ])dnl AC_MSG_ERROR([failed to detect version date: check that git is in your path]) @@ -1528,6 +1494,21 @@ case "$1" in esac ]) +# BOOTSTRAPPING_GHC_INFO_FIELD +# -------------------------------- +# If the bootstrapping compiler is >= 7.1, then set the variable +# $1 to the value of the ghc --info field $2. Otherwise, set it to +# $3. +AC_DEFUN([BOOTSTRAPPING_GHC_INFO_FIELD],[ +if test $GhcCanonVersion -ge 701 +then + $1=`"$WithGhc" --info | grep "^ ,(\"$2\"," | sed -e 's/.*","//' -e 's/")$//'` +else + $1=$3 +fi +AC_SUBST($1) +]) + # LIBRARY_VERSION(lib) # -------------------------------- # Gets the version number of a library. 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 <> put_ bh n get bh = do p <- get bh; n <- get bh; return (Module p n) -INSTANCE_TYPEABLE0(Module,moduleTc,"Module") - instance Data Module where -- don't traverse? toConstr _ = abstractConstr "Module" @@ -280,7 +277,7 @@ pprPackagePrefix p mod = getPprStyle doc \begin{code} -- | Essentially just a string identifying a package, including the version: e.g. parsec-1.0 -newtype PackageId = PId FastString deriving( Eq ) +newtype PackageId = PId FastString deriving( Eq, Typeable ) -- here to avoid module loops with PackageConfig instance Uniquable PackageId where @@ -291,8 +288,6 @@ instance Uniquable PackageId where instance Ord PackageId where nm1 `compare` nm2 = getUnique nm1 `compare` getUnique nm2 -INSTANCE_TYPEABLE0(PackageId,packageIdTc,"PackageId") - instance Data PackageId where -- don't traverse? toConstr _ = abstractConstr "PackageId" diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs index 70cf298..f2ae963 100644 --- a/compiler/basicTypes/Name.lhs +++ b/compiler/basicTypes/Name.lhs @@ -106,6 +106,7 @@ data Name = Name { --(note later when changing Int# -> FastInt: is that still true about UNPACK?) n_loc :: !SrcSpan -- Definition site } + deriving Typeable -- NOTE: we make the n_loc field strict to eliminate some potential -- (and real!) space leaks, due to the fact that we don't look at @@ -363,8 +364,6 @@ instance Uniquable Name where instance NamedThing Name where getName n = n -INSTANCE_TYPEABLE0(Name,nameTc,"Name") - instance Data Name where -- don't traverse? toConstr _ = abstractConstr "Name" diff --git a/compiler/basicTypes/NameSet.lhs b/compiler/basicTypes/NameSet.lhs index e2acaf7..bef9e92 100644 --- a/compiler/basicTypes/NameSet.lhs +++ b/compiler/basicTypes/NameSet.lhs @@ -48,7 +48,12 @@ import Data.Data \begin{code} type NameSet = UniqSet Name -INSTANCE_TYPEABLE0(NameSet,nameSetTc,"NameSet") +-- TODO: These Data/Typeable instances look very dubious. Surely either +-- UniqFM should have the instances, or this should be a newtype? + +nameSetTc :: TyCon +nameSetTc = mkTyCon "NameSet" +instance Typeable NameSet where { typeOf _ = mkTyConApp nameSetTc [] } instance Data NameSet where gfoldl k z s = z mkNameSet `k` nameSetToList s -- traverse abstractly @@ -176,7 +181,7 @@ duDefs dus = foldr get emptyNameSet dus get (Just d1, _u1) d2 = d1 `unionNameSets` d2 allUses :: DefUses -> Uses --- ^ Just like 'allUses', but 'Defs' are not eliminated from the 'Uses' returned +-- ^ Just like 'duUses', but 'Defs' are not eliminated from the 'Uses' returned allUses dus = foldr get emptyNameSet dus where get (_d1, u1) u2 = u1 `unionNameSets` u2 @@ -184,8 +189,7 @@ allUses dus = foldr get emptyNameSet dus duUses :: DefUses -> Uses -- ^ Collect all 'Uses', regardless of whether the group is itself used, -- but remove 'Defs' on the way -duUses dus - = foldr get emptyNameSet dus +duUses dus = foldr get emptyNameSet dus where get (Nothing, rhs_uses) uses = rhs_uses `unionNameSets` uses get (Just defs, rhs_uses) uses = (rhs_uses `unionNameSets` uses) diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs index f02ae8d..5489ea7 100644 --- a/compiler/basicTypes/OccName.lhs +++ b/compiler/basicTypes/OccName.lhs @@ -209,6 +209,7 @@ data OccName = OccName { occNameSpace :: !NameSpace , occNameFS :: !FastString } + deriving Typeable \end{code} @@ -221,8 +222,6 @@ instance Ord OccName where compare (OccName sp1 s1) (OccName sp2 s2) = (s1 `compare` s2) `thenCmp` (sp1 `compare` sp2) -INSTANCE_TYPEABLE0(OccName,occNameTc,"OccName") - instance Data OccName where -- don't traverse? toConstr _ = abstractConstr "OccName" diff --git a/compiler/basicTypes/SrcLoc.lhs b/compiler/basicTypes/SrcLoc.lhs index 5dcdabe..d2cbd7f 100644 --- a/compiler/basicTypes/SrcLoc.lhs +++ b/compiler/basicTypes/SrcLoc.lhs @@ -185,8 +185,6 @@ instance Outputable SrcLoc where ppr (UnhelpfulLoc s) = ftext s -INSTANCE_TYPEABLE0(SrcSpan,srcSpanTc,"SrcSpan") - instance Data SrcSpan where -- don't traverse? toConstr _ = abstractConstr "SrcSpan" @@ -237,10 +235,10 @@ data SrcSpan -- also used to indicate an empty span #ifdef DEBUG - deriving (Eq, Show) -- Show is used by Lexer.x, becuase we - -- derive Show for Token + deriving (Eq, Typeable, Show) -- Show is used by Lexer.x, becuase we + -- derive Show for Token #else - deriving Eq + deriving (Eq, Typeable) #endif -- | Built-in "bad" 'SrcSpan's for common sources of location uncertainty diff --git a/compiler/basicTypes/Var.lhs b/compiler/basicTypes/Var.lhs index ec83494..bca185f 100644 --- a/compiler/basicTypes/Var.lhs +++ b/compiler/basicTypes/Var.lhs @@ -155,6 +155,7 @@ data Var idScope :: IdScope, id_details :: IdDetails, -- Stable, doesn't change id_info :: IdInfo } -- Unstable, updated by simplifier + deriving Typeable data IdScope -- See Note [GlobalId/LocalId] = GlobalId @@ -216,8 +217,6 @@ instance Ord Var where a > b = realUnique a ># realUnique b a `compare` b = varUnique a `compare` varUnique b -INSTANCE_TYPEABLE0(Var,varTc,"Var") - instance Data Var where -- don't traverse? toConstr _ = abstractConstr "Var" diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs index c151a26..901b13b 100644 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -101,7 +101,7 @@ module CLabel ( hasCAF, infoLblToEntryLbl, entryLblToInfoLbl, cvtToClosureLbl, cvtToSRTLbl, needsCDecl, isAsmTemp, maybeAsmTemp, externallyVisibleCLabel, - isMathFun, + isMathFun, isCas, isCFunctionLabel, isGcPtrLabel, labelDynamic, pprCLabel @@ -590,9 +590,17 @@ maybeAsmTemp (AsmTempLabel uq) = Just uq maybeAsmTemp _ = Nothing +-- | Check whether a label corresponds to our cas function. +-- We #include the prototype for this, so we need to avoid +-- generating out own C prototypes. +isCas :: CLabel -> Bool +isCas (CmmLabel pkgId fn _) = pkgId == rtsPackageId && fn == fsLit "cas" +isCas _ = False + + -- | Check whether a label corresponds to a C function that has -- a prototype in a system header somehere, or is built-in --- to the C compiler. For these labels we abovoid generating our +-- to the C compiler. For these labels we avoid generating our -- own C prototypes. isMathFun :: CLabel -> Bool isMathFun (ForeignLabel fs _ _ _) = fs `elementOfUniqSet` math_funs diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs index 2e9f952..54b4b11 100644 --- a/compiler/cmm/Cmm.hs +++ b/compiler/cmm/Cmm.hs @@ -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) 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/CmmParse.y b/compiler/cmm/CmmParse.y index 8c2498e..4dc7e32 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -396,13 +396,15 @@ stmt :: { ExtCode } | NAME '(' exprs0 ')' ';' {% stmtMacro $1 $3 } | 'switch' maybe_range expr '{' arms default '}' - { doSwitch $2 $3 $5 $6 } + { do as <- sequence $5; doSwitch $2 $3 as $6 } | 'goto' NAME ';' { do l <- lookupLabel $2; stmtEC (CmmBranch l) } | 'jump' expr maybe_actuals ';' { do e1 <- $2; e2 <- sequence $3; stmtEC (CmmJump e1 e2) } | 'return' maybe_actuals ';' { do e <- sequence $2; stmtEC (CmmReturn e) } + | 'if' bool_expr 'goto' NAME + { do l <- lookupLabel $4; cmmRawIf $2 l } | 'if' bool_expr '{' body '}' else { cmmIfThenElse $2 $4 $6 } @@ -441,12 +443,16 @@ maybe_range :: { Maybe (Int,Int) } : '[' INT '..' INT ']' { Just (fromIntegral $2, fromIntegral $4) } | {- empty -} { Nothing } -arms :: { [([Int],ExtCode)] } +arms :: { [ExtFCode ([Int],Either BlockId ExtCode)] } : {- empty -} { [] } | arm arms { $1 : $2 } -arm :: { ([Int],ExtCode) } - : 'case' ints ':' '{' body '}' { ($2, $5) } +arm :: { ExtFCode ([Int],Either BlockId ExtCode) } + : 'case' ints ':' arm_body { do b <- $4; return ($2, b) } + +arm_body :: { ExtFCode (Either BlockId ExtCode) } + : '{' body '}' { return (Right $2) } + | 'goto' NAME ';' { do l <- lookupLabel $2; return (Left l) } ints :: { [Int] } : INT { [ fromIntegral $1 ] } @@ -458,6 +464,8 @@ default :: { Maybe ExtCode } -- 'default' branches | {- empty -} { Nothing } +-- Note: OldCmm doesn't support a first class 'else' statement, though +-- CmmNode does. else :: { ExtCode } : {- empty -} { nopEC } | 'else' '{' body '}' { $3 } @@ -952,6 +960,10 @@ cmmIfThenElse cond then_part else_part = do -- fall through to join code (labelC join_id) +cmmRawIf cond then_id = do + c <- cond + emitCond c then_id + -- 'emitCond cond true_id' emits code to test whether the cond is true, -- branching to true_id if so, and falling through otherwise. emitCond (BoolTest e) then_id = do @@ -991,7 +1003,7 @@ emitCond (e1 `BoolAnd` e2) then_id = do -- optional range on the switch (eg. switch [0..7] {...}), or by -- the minimum/maximum values from the branches. -doSwitch :: Maybe (Int,Int) -> ExtFCode CmmExpr -> [([Int],ExtCode)] +doSwitch :: Maybe (Int,Int) -> ExtFCode CmmExpr -> [([Int],Either BlockId ExtCode)] -> Maybe ExtCode -> ExtCode doSwitch mb_range scrut arms deflt = do @@ -1018,12 +1030,12 @@ doSwitch mb_range scrut arms deflt -- ToDo: check for out of range and jump to default if necessary stmtEC (CmmSwitch expr entries) where - emitArm :: ([Int],ExtCode) -> ExtFCode [(Int,BlockId)] - emitArm (ints,code) = do + emitArm :: ([Int],Either BlockId ExtCode) -> ExtFCode [(Int,BlockId)] + emitArm (ints,Left blockid) = return [ (i,blockid) | i <- ints ] + emitArm (ints,Right code) = do blockid <- forkLabelledCodeEC code return [ (i,blockid) | i <- ints ] - -- ----------------------------------------------------------------------------- -- Putting it all together 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/PprC.hs b/compiler/cmm/PprC.hs index 10f4e8b..d363cef 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -248,7 +248,7 @@ pprStmt stmt = case stmt of | CmmNeverReturns <- ret -> let myCall = pprCall (pprCLabel lbl) cconv results args safety in (real_fun_proto lbl, myCall) - | not (isMathFun lbl) -> + | not (isMathFun lbl || isCas lbl) -> let myCall = braces ( pprCFunType (char '*' <> text "ghcFunPtr") cconv results args <> semi $$ text "ghcFunPtr" <+> equals <+> cast_fn <> semi diff --git a/compiler/cmm/cmm-notes b/compiler/cmm/cmm-notes index 0852711..e787f18 100644 --- a/compiler/cmm/cmm-notes +++ b/compiler/cmm/cmm-notes @@ -15,14 +15,11 @@ Things to do: This will fix the spill before stack check problem but only really as a side effect. A 'real fix' probably requires making the spiller know about sp checks. - - There is some silly stuff happening with the Sp. We end up with code like: - Sp = Sp + 8; R1 = _vwf::I64; Sp = Sp -8 - Seems to be perhaps caused by the issue above but also maybe a optimisation - pass needed? + EZY: I don't understand this comment. David Terei, can you clarify? - - Proc pass all arguments on the stack, adding more code and slowing down things - a lot. We either need to fix this or even better would be to get rid of - proc points. + - Proc points pass all arguments on the stack, adding more code and + slowing down things a lot. We either need to fix this or even better + would be to get rid of proc points. - CmmInfo.cmmToRawCmm uses Old.Cmm, so it is called after converting Cmm.Cmm to Old.Cmm. We should abstract it to work on both representations, it needs only to @@ -32,7 +29,7 @@ Things to do: we could convert codeGen/StgCmm* clients to the Hoopl's semantics? It's all deeply unsatisfactory. - - Improve preformance of Hoopl. + - Improve performance of Hoopl. A nofib comparison of -fasm vs -fnewcodegen nofib compilation parameters (using the same ghc-cmm branch +libraries compiled by the old codegenerator) @@ -50,6 +47,9 @@ Things to do: So we generate a bit better code, but it takes us longer! + EZY: Also importantly, Hoopl uses dramatically more memory than the + old code generator. + - Are all blockToNodeList and blockOfNodeList really needed? Maybe we could splice blocks instead? @@ -57,7 +57,7 @@ Things to do: a block catenation function would be probably nicer than blockToNodeList / blockOfNodeList combo. - - loweSafeForeignCall seems too lowlevel. Just use Dataflow. After that + - lowerSafeForeignCall seems too lowlevel. Just use Dataflow. After that delete splitEntrySeq from HooplUtils. - manifestSP seems to touch a lot of the graph representation. It is @@ -76,6 +76,9 @@ Things to do: calling convention, and the code for calling foreign calls is generated - AsmCodeGen has a generic Cmm optimiser; move this into new pipeline + EZY (2011-04-16): The mini-inliner has been generalized and ported, + but the constant folding and other optimizations need to still be + ported. - AsmCodeGen has post-native-cg branch eliminator (shortCutBranches); we ultimately want to share this with the Cmm branch eliminator. @@ -113,7 +116,7 @@ Things to do: - See "CAFs" below; we want to totally refactor the way SRTs are calculated - Pull out Areas into its own module - Parameterise AreaMap + Parameterise AreaMap (note there are type synonyms in CmmStackLayout!) Add ByteWidth = Int type SubArea = (Area, ByteOff, ByteWidth) ByteOff should not be defined in SMRep -- that is too high up the hierarchy @@ -293,8 +296,8 @@ cpsTop: insert spills/reloads across LastCalls, and Branches to proc-points - Now sink those reloads: - - CmmSpillReload.insertLateReloads + Now sink those reloads (and other instructions): + - CmmSpillReload.rewriteAssignments - CmmSpillReload.removeDeadAssignmentsAndReloads * CmmStackLayout.stubSlotsOnDeath @@ -344,7 +347,7 @@ to J that way. This is an awkward choice. (We think that we currently never pass variables to join points via arguments.) Furthermore, there is *no way* to pass q to J in a register (other -than a paramter register). +than a parameter register). What we want is to do register allocation across the whole caboodle. Then we could drop all the code that deals with the above awkward diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index b28f3eb..0daa6be 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.lhs @@ -365,6 +365,20 @@ addTickHsExpr (HsWrap w e) = (return w) (addTickHsExpr e) -- explicitly no tick on inside +addTickHsExpr (HsArrApp e1 e2 ty1 arr_ty lr) = + liftM5 HsArrApp + (addTickLHsExpr e1) + (addTickLHsExpr e2) + (return ty1) + (return arr_ty) + (return lr) + +addTickHsExpr (HsArrForm e fix cmdtop) = + liftM3 HsArrForm + (addTickLHsExpr e) + (return fix) + (mapM (liftL (addTickHsCmdTop)) cmdtop) + addTickHsExpr e@(HsType _) = return e -- Others dhould never happen in expression content. @@ -558,7 +572,7 @@ addTickHsCmd (HsLet binds c) = addTickHsCmd (HsDo cxt stmts last_exp srcloc) = do (stmts', last_exp') <- addTickLCmdStmts' stmts (addTickLHsCmd last_exp) return (HsDo cxt stmts' last_exp' srcloc) - where + addTickHsCmd (HsArrApp e1 e2 ty1 arr_ty lr) = liftM5 HsArrApp (addTickLHsExpr e1) diff --git a/compiler/ghc.mk b/compiler/ghc.mk index a7a353d..76b393f 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -134,8 +134,6 @@ compiler/stage%/build/Config.hs : mk/config.mk mk/project.mk | $$(dir $$@)/. @echo 'cLeadingUnderscore = "$(LeadingUnderscore)"' >> $@ @echo 'cRAWCPP_FLAGS :: String' >> $@ @echo 'cRAWCPP_FLAGS = "$(RAWCPP_FLAGS)"' >> $@ - @echo 'cGCC :: String' >> $@ - @echo 'cGCC = "$(WhatGccIsCalled)"' >> $@ @echo 'cMKDLL :: String' >> $@ @echo 'cMKDLL = "$(BLD_DLL)"' >> $@ @echo 'cLdIsGNULd :: String' >> $@ @@ -162,8 +160,6 @@ compiler/stage%/build/Config.hs : mk/config.mk mk/project.mk | $$(dir $$@)/. @echo 'cGHC_SYSMAN_PGM = "$(GHC_SYSMAN)"' >> $@ @echo 'cGHC_SYSMAN_DIR :: String' >> $@ @echo 'cGHC_SYSMAN_DIR = "$(GHC_SYSMAN_DIR)"' >> $@ - @echo 'cGHC_PERL :: String' >> $@ - @echo 'cGHC_PERL = "$(GHC_PERL)"' >> $@ @echo 'cDEFAULT_TMPDIR :: String' >> $@ @echo 'cDEFAULT_TMPDIR = "$(DEFAULT_TMPDIR)"' >> $@ @echo 'cRelocatableBuild :: Bool' >> $@ diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index 59f5669..b4068a7 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -569,10 +569,10 @@ newVar = liftTcM . newFlexiTyVarTy type RttiInstantiation = [(TcTyVar, TyVar)] -- Associates the typechecker-world meta type variables -- (which are mutable and may be refined), to their - -- debugger-world RuntimeUnkSkol counterparts. + -- debugger-world RuntimeUnk counterparts. -- If the TcTyVar has not been refined by the runtime type -- elaboration, then we want to turn it back into the - -- original RuntimeUnkSkol + -- original RuntimeUnk -- | Returns the instantiated type scheme ty', and the -- mapping from new (instantiated) -to- old (skolem) type variables @@ -1130,9 +1130,9 @@ zonkRttiType = zonkType (mkZonkTcTyVar zonk_unbound_meta) zonk_unbound_meta tv = ASSERT( isTcTyVar tv ) do { tv' <- skolemiseUnboundMetaTyVar tv RuntimeUnk - -- This is where RuntimeUnkSkols are born: + -- This is where RuntimeUnks are born: -- otherwise-unconstrained unification variables are - -- turned into RuntimeUnkSkols as they leave the + -- turned into RuntimeUnks as they leave the -- typechecker's monad ; return (mkTyVarTy tv') } diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index e080bee..675afa2 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -679,16 +679,12 @@ okInstDclSig (TypeSig _ _) = False okInstDclSig (FixSig _) = False okInstDclSig _ = True -sigForThisGroup :: NameSet -> LSig Name -> Bool -sigForThisGroup ns sig - = case sigName sig of - Nothing -> False - Just n -> n `elemNameSet` ns - sigName :: LSig name -> Maybe name +-- Used only in Haddock sigName (L _ sig) = sigNameNoLoc sig sigNameNoLoc :: Sig name -> Maybe name +-- Used only in Haddock sigNameNoLoc (TypeSig n _) = Just (unLoc n) sigNameNoLoc (SpecSig n _ _) = Just (unLoc n) sigNameNoLoc (InlineSig n _) = Just (unLoc n) diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index 345ec32..53d2949 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -3,15 +3,7 @@ % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % - - \begin{code} -{-# OPTIONS -fno-warn-incomplete-patterns #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details {-# LANGUAGE DeriveDataTypeable #-} -- | Abstract syntax of global declarations. @@ -630,15 +622,15 @@ instance OutputableBndr name (ppr new_or_data <+> (if isJust typats then ptext (sLit "instance") else empty) <+> pp_decl_head (unLoc context) ltycon tyvars typats <+> - ppr_sig mb_sig) + ppr_sigx mb_sig) (pp_condecls condecls) derivings where - ppr_sig Nothing = empty - ppr_sig (Just kind) = dcolon <+> pprKind kind + ppr_sigx Nothing = empty + ppr_sigx (Just kind) = dcolon <+> pprKind kind ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars, - tcdFDs = fds, + tcdFDs = fds, tcdSigs = sigs, tcdMeths = methods, tcdATs = ats}) | null sigs && null ats -- No "where" part = top_matter @@ -773,14 +765,14 @@ instance (OutputableBndr name) => Outputable (ConDecl name) where ppr = pprConDecl pprConDecl :: OutputableBndr name => ConDecl name -> SDoc -pprConDecl (ConDecl { con_name =con, con_explicit = expl, con_qvars = tvs +pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs , con_cxt = cxt, con_details = details , con_res = ResTyH98, con_doc = doc }) - = sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details con details] + = sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details details] where - ppr_details con (InfixCon t1 t2) = hsep [ppr t1, pprHsInfix con, ppr t2] - ppr_details con (PrefixCon tys) = hsep (pprHsVar con : map ppr tys) - ppr_details con (RecCon fields) = ppr con <+> pprConDeclFields fields + ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprHsInfix con, ppr t2] + ppr_details (PrefixCon tys) = hsep (pprHsVar con : map ppr tys) + ppr_details (RecCon fields) = ppr con <+> pprConDeclFields fields pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs , con_cxt = cxt, con_details = PrefixCon arg_tys @@ -802,7 +794,7 @@ pprConDecl (ConDecl {con_name = con, con_details = InfixCon {}, con_res = ResTyG %************************************************************************ %* * -\subsection[InstDecl]{An instance declaration +\subsection[InstDecl]{An instance declaration} %* * %************************************************************************ @@ -835,7 +827,7 @@ instDeclATs inst_decls = [at | L _ (InstDecl _ _ _ ats) <- inst_decls, at <- ats %************************************************************************ %* * -\subsection[DerivDecl]{A stand-alone instance deriving declaration +\subsection[DerivDecl]{A stand-alone instance deriving declaration} %* * %************************************************************************ diff --git a/compiler/hsSyn/HsImpExp.lhs b/compiler/hsSyn/HsImpExp.lhs index dd24aed..5015999 100644 --- a/compiler/hsSyn/HsImpExp.lhs +++ b/compiler/hsSyn/HsImpExp.lhs @@ -6,12 +6,6 @@ HsImpExp: Abstract syntax: imports, exports, interfaces \begin{code} -{-# OPTIONS -fno-warn-incomplete-patterns #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details {-# LANGUAGE DeriveDataTypeable #-} module HsImpExp where @@ -103,6 +97,7 @@ ieName (IEVar n) = n ieName (IEThingAbs n) = n ieName (IEThingWith n _) = n ieName (IEThingAll n) = n +ieName _ = panic "ieName failed pattern match!" ieNames :: IE a -> [a] ieNames (IEVar n ) = [n] @@ -122,8 +117,8 @@ instance (Outputable name) => Outputable (IE name) where ppr (IEThingAll thing) = hcat [ppr thing, text "(..)"] ppr (IEThingWith thing withs) = ppr thing <> parens (fsep (punctuate comma (map pprHsVar withs))) - ppr (IEModuleContents mod) - = ptext (sLit "module") <+> ppr mod + ppr (IEModuleContents mod') + = ptext (sLit "module") <+> ppr mod' ppr (IEGroup n _) = text ("") ppr (IEDoc doc) = ppr doc ppr (IEDocNamed string) = text ("") diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index b940cb1..c327006 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -900,8 +900,8 @@ mk_usage_info pit hsc_env this_mod direct_imports used_names finsts_mod = mi_finsts iface hash_env = mi_hash_fn iface mod_hash = mi_mod_hash iface - export_hash | depend_on_exports mod = Just (mi_exp_hash iface) - | otherwise = Nothing + export_hash | depend_on_exports = Just (mi_exp_hash iface) + | otherwise = Nothing used_occs = lookupModuleEnv ent_map mod `orElse` [] @@ -918,21 +918,21 @@ mk_usage_info pit hsc_env this_mod direct_imports used_names Nothing -> pprPanic "mkUsage" (ppr mod <+> ppr occ <+> ppr used_names) Just r -> r - depend_on_exports mod = - case lookupModuleEnv direct_imports mod of - Just _ -> True - -- Even if we used 'import M ()', we have to register a - -- usage on the export list because we are sensitive to - -- changes in orphan instances/rules. - Nothing -> False - -- In GHC 6.8.x the above line read "True", and in - -- fact it recorded a dependency on *all* the - -- modules underneath in the dependency tree. This - -- happens to make orphans work right, but is too - -- expensive: it'll read too many interface files. - -- The 'isNothing maybe_iface' check above saved us - -- from generating many of these usages (at least in - -- one-shot mode), but that's even more bogus! + depend_on_exports = is_direct_import + {- True + Even if we used 'import M ()', we have to register a + usage on the export list because we are sensitive to + changes in orphan instances/rules. + False + In GHC 6.8.x we always returned true, and in + fact it recorded a dependency on *all* the + modules underneath in the dependency tree. This + happens to make orphans work right, but is too + expensive: it'll read too many interface files. + The 'isNothing maybe_iface' check above saved us + from generating many of these usages (at least in + one-shot mode), but that's even more bogus! + -} \end{code} \begin{code} diff --git a/compiler/llvmGen/LlvmCodeGen/Regs.hs b/compiler/llvmGen/LlvmCodeGen/Regs.hs index 661dc9a..b0c63a4 100644 --- a/compiler/llvmGen/LlvmCodeGen/Regs.hs +++ b/compiler/llvmGen/LlvmCodeGen/Regs.hs @@ -38,6 +38,8 @@ lmGlobalReg suf reg VanillaReg 4 _ -> wordGlobal $ "R4" ++ suf VanillaReg 5 _ -> wordGlobal $ "R5" ++ suf VanillaReg 6 _ -> wordGlobal $ "R6" ++ suf + VanillaReg 7 _ -> wordGlobal $ "R7" ++ suf + VanillaReg 8 _ -> wordGlobal $ "R8" ++ suf SpLim -> wordGlobal $ "SpLim" ++ suf FloatReg 1 -> floatGlobal $"F1" ++ suf FloatReg 2 -> floatGlobal $"F2" ++ suf diff --git a/compiler/main/DriverMkDepend.hs b/compiler/main/DriverMkDepend.hs index e430c6e..1694aba 100644 --- a/compiler/main/DriverMkDepend.hs +++ b/compiler/main/DriverMkDepend.hs @@ -16,7 +16,6 @@ module DriverMkDepend ( #include "HsVersions.h" import qualified GHC --- import GHC ( ModSummary(..), GhcMonad ) import GhcMonad import HsSyn ( ImportDecl(..) ) import DynFlags @@ -35,7 +34,6 @@ import FastString import Exception import ErrUtils --- import MonadUtils ( liftIO ) import System.Directory import System.FilePath diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 61486fc..f92a411 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -779,9 +779,9 @@ runPhase (Cpp sf) input_fn dflags0 src_opts <- io $ getOptionsFromFile dflags0 output_fn (dflags2, unhandled_flags, warns) <- io $ parseDynamicNoPackageFlags dflags0 src_opts + io $ checkProcessArgsResult unhandled_flags unless (dopt Opt_Pp dflags2) $ io $ handleFlagWarnings dflags2 warns -- the HsPp pass below will emit warnings - io $ checkProcessArgsResult unhandled_flags setDynFlags dflags2 @@ -814,8 +814,8 @@ runPhase (HsPp sf) input_fn dflags (dflags1, unhandled_flags, warns) <- io $ parseDynamicNoPackageFlags dflags src_opts setDynFlags dflags1 - io $ handleFlagWarnings dflags1 warns io $ checkProcessArgsResult unhandled_flags + io $ handleFlagWarnings dflags1 warns return (Hsc sf, output_fn) @@ -1028,10 +1028,10 @@ runPhase cc_phase input_fn dflags (cmdline_include_paths ++ pkg_include_dirs) let md_c_flags = machdepCCOpts dflags - gcc_extra_viac_flags <- io $ getExtraViaCOpts dflags + let gcc_extra_viac_flags = extraGccViaCFlags 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 9f504a1..67065d0 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -1,6 +1,3 @@ -{-# OPTIONS_GHC -w #-} --- Temporary, until rtsIsProfiled is fixed - -- | -- Dynamic flags -- @@ -35,12 +32,21 @@ module DynFlags ( DPHBackend(..), dphPackageMaybe, wayNames, + Settings(..), + ghcUsagePath, ghciUsagePath, topDir, tmpDir, rawSettings, + extraGccViaCFlags, systemPackageConfig, + pgm_L, pgm_P, pgm_F, pgm_c, pgm_s, pgm_a, pgm_l, pgm_dll, pgm_T, + pgm_sysman, pgm_windres, pgm_lo, pgm_lc, + opt_L, opt_P, opt_F, opt_c, opt_m, opt_a, opt_l, + opt_windres, opt_lo, opt_lc, + + -- ** Manipulating DynFlags - defaultDynFlags, -- DynFlags + defaultDynFlags, -- Settings -> DynFlags initDynFlags, -- DynFlags -> IO DynFlags getOpts, -- DynFlags -> (DynFlags -> [a]) -> [a] - getVerbFlag, + getVerbFlags, updOptLevel, setTmpDir, setPackageName, @@ -61,7 +67,6 @@ module DynFlags ( getStgToDo, -- * Compiler configuration suitable for display to the user - Printable(..), compilerInfo #ifdef GHCI -- Only in stage 2 can we be sure that the RTS @@ -90,10 +95,14 @@ import Maybes ( orElse ) import SrcLoc import FastString import Outputable +#ifdef GHCI import Foreign.C ( CInt ) +#endif import {-# SOURCE #-} ErrUtils ( Severity(..), Message, mkLocMessage ) +#ifdef GHCI import System.IO.Unsafe ( unsafePerformIO ) +#endif import Data.IORef import Control.Monad ( when ) @@ -101,7 +110,7 @@ import Data.Char import Data.List import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe +-- import Data.Maybe import System.FilePath import System.IO ( stderr, hPutChar ) @@ -440,41 +449,13 @@ data DynFlags = DynFlags { libraryPaths :: [String], frameworkPaths :: [String], -- used on darwin only cmdlineFrameworks :: [String], -- ditto - tmpDir :: String, -- no trailing '/' - ghcUsagePath :: FilePath, -- Filled in by SysTools - ghciUsagePath :: FilePath, -- ditto rtsOpts :: Maybe String, rtsOptsEnabled :: RtsOptsEnabled, hpcDir :: String, -- ^ Path to store the .mix files - -- options for particular phases - opt_L :: [String], - opt_P :: [String], - opt_F :: [String], - opt_c :: [String], - opt_m :: [String], - opt_a :: [String], - opt_l :: [String], - opt_windres :: [String], - opt_lo :: [String], -- LLVM: llvm optimiser - opt_lc :: [String], -- LLVM: llc static compiler - - -- commands for particular phases - pgm_L :: String, - pgm_P :: (String,[Option]), - pgm_F :: String, - pgm_c :: (String,[Option]), - pgm_s :: (String,[Option]), - pgm_a :: (String,[Option]), - pgm_l :: (String,[Option]), - pgm_dll :: (String,[Option]), - pgm_T :: String, - pgm_sysman :: String, - pgm_windres :: String, - pgm_lo :: (String,[Option]), -- LLVM: opt llvm optimiser - pgm_lc :: (String,[Option]), -- LLVM: llc static compiler + settings :: Settings, -- For ghc -M depMakefile :: FilePath, @@ -484,8 +465,6 @@ data DynFlags = DynFlags { -- Package flags extraPkgConfs :: [FilePath], - topDir :: FilePath, -- filled in by SysTools - systemPackageConfig :: FilePath, -- ditto -- ^ The @-package-conf@ flags given on the command line, in the order -- they appeared. @@ -520,6 +499,105 @@ data DynFlags = DynFlags { haddockOptions :: Maybe String } +data Settings = Settings { + sGhcUsagePath :: FilePath, -- Filled in by SysTools + sGhciUsagePath :: FilePath, -- ditto + sTopDir :: FilePath, + sTmpDir :: String, -- no trailing '/' + -- You shouldn't need to look things up in rawSettings directly. + -- They should have their own fields instead. + sRawSettings :: [(String, String)], + sExtraGccViaCFlags :: [String], + sSystemPackageConfig :: FilePath, + -- commands for particular phases + sPgm_L :: String, + sPgm_P :: (String,[Option]), + sPgm_F :: String, + sPgm_c :: (String,[Option]), + sPgm_s :: (String,[Option]), + sPgm_a :: (String,[Option]), + sPgm_l :: (String,[Option]), + sPgm_dll :: (String,[Option]), + sPgm_T :: String, + sPgm_sysman :: String, + sPgm_windres :: String, + sPgm_lo :: (String,[Option]), -- LLVM: opt llvm optimiser + sPgm_lc :: (String,[Option]), -- LLVM: llc static compiler + -- options for particular phases + sOpt_L :: [String], + sOpt_P :: [String], + sOpt_F :: [String], + sOpt_c :: [String], + sOpt_m :: [String], + sOpt_a :: [String], + sOpt_l :: [String], + sOpt_windres :: [String], + sOpt_lo :: [String], -- LLVM: llvm optimiser + sOpt_lc :: [String] -- LLVM: llc static compiler + + } + +ghcUsagePath :: DynFlags -> FilePath +ghcUsagePath dflags = sGhcUsagePath (settings dflags) +ghciUsagePath :: DynFlags -> FilePath +ghciUsagePath dflags = sGhciUsagePath (settings dflags) +topDir :: DynFlags -> FilePath +topDir dflags = sTopDir (settings dflags) +tmpDir :: DynFlags -> String +tmpDir dflags = sTmpDir (settings dflags) +rawSettings :: DynFlags -> [(String, String)] +rawSettings dflags = sRawSettings (settings dflags) +extraGccViaCFlags :: DynFlags -> [String] +extraGccViaCFlags dflags = sExtraGccViaCFlags (settings dflags) +systemPackageConfig :: DynFlags -> FilePath +systemPackageConfig dflags = sSystemPackageConfig (settings dflags) +pgm_L :: DynFlags -> String +pgm_L dflags = sPgm_L (settings dflags) +pgm_P :: DynFlags -> (String,[Option]) +pgm_P dflags = sPgm_P (settings dflags) +pgm_F :: DynFlags -> String +pgm_F dflags = sPgm_F (settings dflags) +pgm_c :: DynFlags -> (String,[Option]) +pgm_c dflags = sPgm_c (settings dflags) +pgm_s :: DynFlags -> (String,[Option]) +pgm_s dflags = sPgm_s (settings dflags) +pgm_a :: DynFlags -> (String,[Option]) +pgm_a dflags = sPgm_a (settings dflags) +pgm_l :: DynFlags -> (String,[Option]) +pgm_l dflags = sPgm_l (settings dflags) +pgm_dll :: DynFlags -> (String,[Option]) +pgm_dll dflags = sPgm_dll (settings dflags) +pgm_T :: DynFlags -> String +pgm_T dflags = sPgm_T (settings dflags) +pgm_sysman :: DynFlags -> String +pgm_sysman dflags = sPgm_sysman (settings dflags) +pgm_windres :: DynFlags -> String +pgm_windres dflags = sPgm_windres (settings dflags) +pgm_lo :: DynFlags -> (String,[Option]) +pgm_lo dflags = sPgm_lo (settings dflags) +pgm_lc :: DynFlags -> (String,[Option]) +pgm_lc dflags = sPgm_lc (settings dflags) +opt_L :: DynFlags -> [String] +opt_L dflags = sOpt_L (settings dflags) +opt_P :: DynFlags -> [String] +opt_P dflags = sOpt_P (settings dflags) +opt_F :: DynFlags -> [String] +opt_F dflags = sOpt_F (settings dflags) +opt_c :: DynFlags -> [String] +opt_c dflags = sOpt_c (settings dflags) +opt_m :: DynFlags -> [String] +opt_m dflags = sOpt_m (settings dflags) +opt_a :: DynFlags -> [String] +opt_a dflags = sOpt_a (settings dflags) +opt_l :: DynFlags -> [String] +opt_l dflags = sOpt_l (settings dflags) +opt_windres :: DynFlags -> [String] +opt_windres dflags = sOpt_windres (settings dflags) +opt_lo :: DynFlags -> [String] +opt_lo dflags = sOpt_lo (settings dflags) +opt_lc :: DynFlags -> [String] +opt_lc dflags = sOpt_lc (settings dflags) + wayNames :: DynFlags -> [WayName] wayNames = map wayName . ways @@ -642,8 +720,8 @@ initDynFlags dflags = do -- | The normal 'DynFlags'. Note that they is not suitable for use in this form -- and must be fully initialized by 'GHC.newSession' first. -defaultDynFlags :: DynFlags -defaultDynFlags = +defaultDynFlags :: Settings -> DynFlags +defaultDynFlags mySettings = DynFlags { ghcMode = CompManager, ghcLink = LinkBinary, @@ -693,25 +771,11 @@ defaultDynFlags = libraryPaths = [], frameworkPaths = [], cmdlineFrameworks = [], - tmpDir = cDEFAULT_TMPDIR, rtsOpts = Nothing, rtsOptsEnabled = RtsOptsSafeOnly, hpcDir = ".hpc", - opt_L = [], - opt_P = (if opt_PIC - then ["-D__PIC__", "-U __PIC__"] -- this list is reversed - else []), - opt_F = [], - opt_c = [], - opt_a = [], - opt_m = [], - opt_l = [], - opt_windres = [], - opt_lo = [], - opt_lc = [], - extraPkgConfs = [], packageFlags = [], pkgDatabase = Nothing, @@ -720,25 +784,7 @@ defaultDynFlags = buildTag = panic "defaultDynFlags: No buildTag", rtsBuildTag = panic "defaultDynFlags: No rtsBuildTag", splitInfo = Nothing, - -- initSysTools fills all these in - ghcUsagePath = panic "defaultDynFlags: No ghciUsagePath", - ghciUsagePath = panic "defaultDynFlags: No ghciUsagePath", - topDir = panic "defaultDynFlags: No topDir", - systemPackageConfig = panic "no systemPackageConfig: call GHC.setSessionDynFlags", - pgm_L = panic "defaultDynFlags: No pgm_L", - pgm_P = panic "defaultDynFlags: No pgm_P", - pgm_F = panic "defaultDynFlags: No pgm_F", - pgm_c = panic "defaultDynFlags: No pgm_c", - pgm_s = panic "defaultDynFlags: No pgm_s", - pgm_a = panic "defaultDynFlags: No pgm_a", - pgm_l = panic "defaultDynFlags: No pgm_l", - pgm_dll = panic "defaultDynFlags: No pgm_dll", - pgm_T = panic "defaultDynFlags: No pgm_T", - pgm_sysman = panic "defaultDynFlags: No pgm_sysman", - pgm_windres = panic "defaultDynFlags: No pgm_windres", - pgm_lo = panic "defaultDynFlags: No pgm_lo", - pgm_lc = panic "defaultDynFlags: No pgm_lc", - -- end of initSysTools values + settings = mySettings, -- ghc -M values depMakefile = "Makefile", depIncludePkgDeps = False, @@ -873,10 +919,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, @@ -912,9 +958,9 @@ setDumpPrefixForce f d = d { dumpPrefixForce = f} -- XXX HACK: Prelude> words "'does not' work" ===> ["'does","not'","work"] -- Config.hs should really use Option. -setPgmP f d = let (pgm:args) = words f in d{ pgm_P = (pgm, map Option args)} -addOptl f d = d{ opt_l = f : opt_l d} -addOptP f d = d{ opt_P = f : opt_P d} +setPgmP f = let (pgm:args) = words f in alterSettings (\s -> s { sPgm_P = (pgm, map Option args)}) +addOptl f = alterSettings (\s -> s { sOpt_l = f : sOpt_l s}) +addOptP f = alterSettings (\s -> s { sOpt_P = f : sOpt_P s}) setDepMakefile :: FilePath -> DynFlags -> DynFlags @@ -1095,30 +1141,30 @@ dynamic_flags = [ ------- Specific phases -------------------------------------------- -- need to appear before -pgmL to be parsed as LLVM flags. - , Flag "pgmlo" (hasArg (\f d -> d{ pgm_lo = (f,[])})) - , Flag "pgmlc" (hasArg (\f d -> d{ pgm_lc = (f,[])})) - , Flag "pgmL" (hasArg (\f d -> d{ pgm_L = f})) + , Flag "pgmlo" (hasArg (\f -> alterSettings (\s -> s { sPgm_lo = (f,[])}))) + , Flag "pgmlc" (hasArg (\f -> alterSettings (\s -> s { sPgm_lc = (f,[])}))) + , Flag "pgmL" (hasArg (\f -> alterSettings (\s -> s { sPgm_L = f}))) , Flag "pgmP" (hasArg setPgmP) - , Flag "pgmF" (hasArg (\f d -> d{ pgm_F = f})) - , Flag "pgmc" (hasArg (\f d -> d{ pgm_c = (f,[])})) + , Flag "pgmF" (hasArg (\f -> alterSettings (\s -> s { sPgm_F = f}))) + , Flag "pgmc" (hasArg (\f -> alterSettings (\s -> s { sPgm_c = (f,[])}))) , Flag "pgmm" (HasArg (\_ -> addWarn "The -keep-raw-s-files flag does nothing; it will be removed in a future GHC release")) - , Flag "pgms" (hasArg (\f d -> d{ pgm_s = (f,[])})) - , Flag "pgma" (hasArg (\f d -> d{ pgm_a = (f,[])})) - , Flag "pgml" (hasArg (\f d -> d{ pgm_l = (f,[])})) - , Flag "pgmdll" (hasArg (\f d -> d{ pgm_dll = (f,[])})) - , Flag "pgmwindres" (hasArg (\f d -> d{ pgm_windres = f})) + , Flag "pgms" (hasArg (\f -> alterSettings (\s -> s { sPgm_s = (f,[])}))) + , Flag "pgma" (hasArg (\f -> alterSettings (\s -> s { sPgm_a = (f,[])}))) + , Flag "pgml" (hasArg (\f -> alterSettings (\s -> s { sPgm_l = (f,[])}))) + , Flag "pgmdll" (hasArg (\f -> alterSettings (\s -> s { sPgm_dll = (f,[])}))) + , Flag "pgmwindres" (hasArg (\f -> alterSettings (\s -> s { sPgm_windres = f}))) -- need to appear before -optl/-opta to be parsed as LLVM flags. - , Flag "optlo" (hasArg (\f d -> d{ opt_lo = f : opt_lo d})) - , Flag "optlc" (hasArg (\f d -> d{ opt_lc = f : opt_lc d})) - , Flag "optL" (hasArg (\f d -> d{ opt_L = f : opt_L d})) + , Flag "optlo" (hasArg (\f -> alterSettings (\s -> s { sOpt_lo = f : sOpt_lo s}))) + , Flag "optlc" (hasArg (\f -> alterSettings (\s -> s { sOpt_lc = f : sOpt_lc s}))) + , Flag "optL" (hasArg (\f -> alterSettings (\s -> s { sOpt_L = f : sOpt_L s}))) , Flag "optP" (hasArg addOptP) - , Flag "optF" (hasArg (\f d -> d{ opt_F = f : opt_F d})) - , Flag "optc" (hasArg (\f d -> d{ opt_c = f : opt_c d})) - , Flag "optm" (hasArg (\f d -> d{ opt_m = f : opt_m d})) - , Flag "opta" (hasArg (\f d -> d{ opt_a = f : opt_a d})) + , Flag "optF" (hasArg (\f -> alterSettings (\s -> s { sOpt_F = f : sOpt_F s}))) + , Flag "optc" (hasArg (\f -> alterSettings (\s -> s { sOpt_c = f : sOpt_c s}))) + , Flag "optm" (hasArg (\f -> alterSettings (\s -> s { sOpt_m = f : sOpt_m s}))) + , Flag "opta" (hasArg (\f -> alterSettings (\s -> s { sOpt_a = f : sOpt_a s}))) , Flag "optl" (hasArg addOptl) - , Flag "optwindres" (hasArg (\f d -> d{ opt_windres = f : opt_windres d})) + , Flag "optwindres" (hasArg (\f -> alterSettings (\s -> s { sOpt_windres = f : sOpt_windres s}))) , Flag "split-objs" (NoArg (if can_split @@ -1317,7 +1363,7 @@ dynamic_flags = [ , Flag "fcontext-stack" (intSuffix (\n d -> d{ ctxtStkDepth = n })) , Flag "fstrictness-before" (intSuffix (\n d -> d{ strictnessBefore = n : strictnessBefore d })) , Flag "ffloat-lam-args" (intSuffix (\n d -> d{ floatLamArgs = Just n })) - , Flag "ffloat-all-lams" (intSuffix (\n d -> d{ floatLamArgs = Nothing })) + , Flag "ffloat-all-lams" (noArg (\d -> d{ floatLamArgs = Nothing })) ------ Profiling ---------------------------------------------------- @@ -1833,18 +1879,20 @@ foreign import ccall unsafe "rts_isProfiled" rtsIsProfiledIO :: IO CInt rtsIsProfiled :: Bool rtsIsProfiled = unsafePerformIO rtsIsProfiledIO /= 0 +#endif checkTemplateHaskellOk :: Bool -> DynP () -checkTemplateHaskellOk turn_on +#ifdef GHCI +checkTemplateHaskellOk turn_on | turn_on && rtsIsProfiled = addErr "You can't use Template Haskell with a profiled compiler" | otherwise = return () #else --- In stage 1 we don't know that the RTS has rts_isProfiled, +-- In stage 1 we don't know that the RTS has rts_isProfiled, -- so we simply say "ok". It doesn't matter because TH isn't -- available in stage 1 anyway. -checkTemplateHaskellOk turn_on = return () +checkTemplateHaskellOk _ = return () #endif {- ********************************************************************** @@ -1901,6 +1949,10 @@ unSetExtensionFlag f = upd (\dfs -> xopt_unset dfs f) -- (except for -fno-glasgow-exts, which is treated specially) -------------------------- +alterSettings :: (Settings -> Settings) -> DynFlags -> DynFlags +alterSettings f dflags = dflags { settings = f (settings dflags) } + +-------------------------- setDumpFlag' :: DynFlag -> DynP () setDumpFlag' dump_flag = do { setDynFlag dump_flag @@ -2115,7 +2167,7 @@ splitPathList s = filter notNull (splitUp s) -- tmpDir, where we store temporary files. setTmpDir :: FilePath -> DynFlags -> DynFlags -setTmpDir dir dflags = dflags{ tmpDir = normalise dir } +setTmpDir dir = alterSettings (\s -> s { sTmpDir = normalise dir }) -- we used to fix /cygdrive/c/.. on Windows, but this doesn't -- seem necessary now --SDM 7/2/2008 @@ -2140,17 +2192,16 @@ setOptHpcDir arg = upd $ \ d -> d{hpcDir = arg} -- There are some options that we need to pass to gcc when compiling -- Haskell code via C, but are only supported by recent versions of -- gcc. The configure script decides which of these options we need, --- and puts them in the file "extra-gcc-opts" in $topdir, which is --- read before each via-C compilation. The advantage of having these --- in a separate file is that the file can be created at install-time --- depending on the available gcc version, and even re-generated later --- if gcc is upgraded. +-- and puts them in the "settings" file in $topdir. The advantage of +-- having these in a separate file is that the file can be created at +-- install-time depending on the available gcc version, and even +-- re-generated later if gcc is upgraded. -- -- The options below are not dependent on the version of gcc, only the -- platform. machdepCCOpts :: DynFlags -> [String] -- flags for all C compilations -machdepCCOpts dflags = cCcOpts ++ machdepCCOpts' +machdepCCOpts _ = cCcOpts ++ machdepCCOpts' machdepCCOpts' :: [String] -- flags for all C compilations machdepCCOpts' @@ -2222,30 +2273,35 @@ can_split = cSupportsSplitObjs == "YES" -- ----------------------------------------------------------------------------- -- Compiler Info -data Printable = String String - | FromDynFlags (DynFlags -> String) - -compilerInfo :: [(String, Printable)] -compilerInfo = [("Project name", String cProjectName), - ("Project version", String cProjectVersion), - ("Booter version", String cBooterVersion), - ("Stage", String cStage), - ("Build platform", String cBuildPlatformString), - ("Host platform", String cHostPlatformString), - ("Target platform", String cTargetPlatformString), - ("Have interpreter", String cGhcWithInterpreter), - ("Object splitting supported", String cSupportsSplitObjs), - ("Have native code generator", String cGhcWithNativeCodeGen), - ("Support SMP", String cGhcWithSMP), - ("Unregisterised", String cGhcUnregisterised), - ("Tables next to code", String cGhcEnableTablesNextToCode), - ("RTS ways", String cGhcRTSWays), - ("Leading underscore", String cLeadingUnderscore), - ("Debug on", String (show debugIsOn)), - ("LibDir", FromDynFlags topDir), - ("Global Package DB", FromDynFlags systemPackageConfig), - ("C compiler flags", String (show cCcOpts)), - ("Gcc Linker flags", String (show cGccLinkerOpts)), - ("Ld Linker flags", String (show cLdLinkerOpts)) - ] +compilerInfo :: DynFlags -> [(String, String)] +compilerInfo dflags + = -- We always make "Project name" be first to keep parsing in + -- other languages simple, i.e. when looking for other fields, + -- you don't have to worry whether there is a leading '[' or not + ("Project name", cProjectName) + -- Next come the settings, so anything else can be overridden + -- in the settings file (as "lookup" uses the first match for the + -- key) + : rawSettings dflags + ++ [("Project version", cProjectVersion), + ("Booter version", cBooterVersion), + ("Stage", cStage), + ("Build platform", cBuildPlatformString), + ("Host platform", cHostPlatformString), + ("Target platform", cTargetPlatformString), + ("Have interpreter", cGhcWithInterpreter), + ("Object splitting supported", cSupportsSplitObjs), + ("Have native code generator", cGhcWithNativeCodeGen), + ("Support SMP", cGhcWithSMP), + ("Unregisterised", cGhcUnregisterised), + ("Tables next to code", cGhcEnableTablesNextToCode), + ("RTS ways", cGhcRTSWays), + ("Leading underscore", cLeadingUnderscore), + ("Debug on", show debugIsOn), + ("LibDir", topDir dflags), + ("Global Package DB", systemPackageConfig dflags), + ("C compiler flags", show cCcOpts), + ("Gcc Linker flags", show cGccLinkerOpts), + ("Ld Linker flags", show cLdLinkerOpts) + ] diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index ca2e14c..a9e652d 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -431,8 +431,8 @@ initGhcMonad mb_top_dir = do liftIO $ StaticFlags.initStaticOpts - dflags0 <- liftIO $ initDynFlags defaultDynFlags - dflags <- liftIO $ initSysTools mb_top_dir dflags0 + mySettings <- liftIO $ initSysTools mb_top_dir + dflags <- liftIO $ initDynFlags (defaultDynFlags mySettings) env <- liftIO $ newHscEnv dflags setSession env diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs index 0d41435..ab65894 100644 --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs @@ -1405,17 +1405,14 @@ preprocessFile hsc_env src_fn mb_phase Nothing preprocessFile hsc_env src_fn mb_phase (Just (buf, _time)) = do let dflags = hsc_dflags hsc_env - -- case we bypass the preprocessing stage? - let - local_opts = getOptions dflags buf src_fn - -- + let local_opts = getOptions dflags buf src_fn + (dflags', leftovers, warns) <- parseDynamicNoPackageFlags dflags local_opts checkProcessArgsResult leftovers handleFlagWarnings dflags' warns - let - needs_preprocessing + let needs_preprocessing | Just (Unlit _) <- mb_phase = True | Nothing <- mb_phase, Unlit _ <- startPhase src_fn = True -- note: local_opts is only required if there's no Unlit phase diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index 70ddd6a..36e53a8 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -1132,12 +1132,11 @@ hscTcExpr -- Typecheck an expression (but don't run it) hscTcExpr hsc_env expr = runHsc hsc_env $ do maybe_stmt <- hscParseStmt expr case maybe_stmt of - Just (L _ (ExprStmt expr _ _)) -> - ioMsgMaybe $ tcRnExpr hsc_env (hsc_IC hsc_env) expr - _ -> - liftIO $ throwIO $ mkSrcErr $ unitBag $ - mkPlainErrMsg noSrcSpan - (text "not an expression:" <+> quotes (text expr)) + Just (L _ (ExprStmt expr _ _)) -> + ioMsgMaybe $ tcRnExpr hsc_env (hsc_IC hsc_env) expr + _ -> + liftIO $ throwIO $ mkSrcErr $ unitBag $ mkPlainErrMsg noSrcSpan + (text "not an expression:" <+> quotes (text expr)) -- | Find the kind of a type hscKcType diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index e59c223..11f1a8b 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -717,7 +717,7 @@ type ImportedMods = ModuleEnv [(ModuleName, Bool, SrcSpan)] -- | A ModGuts is carried through the compiler, accumulating stuff as it goes -- There is only one ModGuts at any time, the one for the module -- being compiled right now. Once it is compiled, a 'ModIface' and --- 'ModDetails' are extracted and the ModGuts is dicarded. +-- 'ModDetails' are extracted and the ModGuts is discarded. data ModGuts = ModGuts { mg_module :: !Module, -- ^ Module being compiled diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index 5e265e8..451f78d 100644 --- a/compiler/main/Packages.lhs +++ b/compiler/main/Packages.lhs @@ -36,7 +36,7 @@ where #include "HsVersions.h" import PackageConfig -import DynFlags ( dopt, DynFlag(..), DynFlags(..), PackageFlag(..), DPHBackend(..) ) +import DynFlags import StaticFlags import Config ( cProjectVersion ) import Name ( Name, nameModule_maybe ) diff --git a/compiler/main/StaticFlagParser.hs b/compiler/main/StaticFlagParser.hs index 54f0a92..5767a52 100644 --- a/compiler/main/StaticFlagParser.hs +++ b/compiler/main/StaticFlagParser.hs @@ -210,7 +210,6 @@ unregFlags :: [Located String] unregFlags = map (mkGeneralLocated "in unregFlags") [ "-optc-DNO_REGS" , "-optc-DUSE_MINIINTERPRETER" - , "-fno-asm-mangling" , "-funregisterised" ] ----------------------------------------------------------------------------- diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs index e080cd8..732224b 100644 --- a/compiler/main/StaticFlags.hs +++ b/compiler/main/StaticFlags.hs @@ -167,7 +167,7 @@ try_read sw str = case reads str of ((x,_):_) -> x -- Be forgiving: ignore trailing goop, and alternative parses [] -> ghcError (UsageError ("Malformed argument " ++ str ++ " for flag " ++ sw)) - -- ToDo: hack alert. We should really parse the arugments + -- ToDo: hack alert. We should really parse the arguments -- and announce errors in a more civilised way. diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index 5c64a34..2529dbf 100644 --- a/compiler/main/SysTools.lhs +++ b/compiler/main/SysTools.lhs @@ -26,7 +26,6 @@ module SysTools ( touch, -- String -> String -> IO () copy, copyWithHeader, - getExtraViaCOpts, -- Temporary-file management setTmpDir, @@ -47,6 +46,7 @@ import ErrUtils import Panic import Util import DynFlags +import StaticFlags import Exception import Data.IORef @@ -148,25 +148,44 @@ stuff. \begin{code} initSysTools :: Maybe String -- Maybe TopDir path (without the '-B' prefix) - - -> DynFlags - -> IO DynFlags -- Set all the mutable variables above, holding + -> IO Settings -- Set all the mutable variables above, holding -- (a) the system programs -- (b) the package-config file -- (c) the GHC usage message - - -initSysTools mbMinusB dflags0 +initSysTools mbMinusB = do { top_dir <- findTopDir mbMinusB -- see [Note topdir] -- NB: top_dir is assumed to be in standard Unix -- format, '/' separated - ; let installed :: FilePath -> FilePath + ; let settingsFile = top_dir "settings" + installed :: FilePath -> FilePath installed file = top_dir file installed_mingw_bin file = top_dir ".." "mingw" "bin" file installed_perl_bin file = top_dir ".." "perl" file + ; settingsStr <- readFile settingsFile + ; mySettings <- case maybeReadFuzzy settingsStr of + Just s -> + return s + Nothing -> + pgmError ("Can't parse " ++ show settingsFile) + ; let getSetting key = case lookup key mySettings of + Just xs -> + return xs + Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile) + ; myExtraGccViaCFlags <- getSetting "GCC extra via C opts" + -- On Windows, mingw is distributed with GHC, + -- so we look in TopDir/../mingw/bin + -- It would perhaps be nice to be able to override this + -- with the settings file, but it would be a little fiddly + -- to make that possible, so for now you can't. + ; gcc_prog <- if isWindowsHost then return $ installed_mingw_bin "gcc" + else getSetting "C compiler command" + ; perl_path <- if isWindowsHost + then return $ installed_perl_bin "perl" + else getSetting "perl command" + ; let pkgconfig_path = installed "package.conf.d" ghc_usage_msg_path = installed "ghc-usage.txt" ghci_usage_msg_path = installed "ghci-usage.txt" @@ -181,17 +200,8 @@ initSysTools mbMinusB dflags0 windres_path = installed_mingw_bin "windres" ; tmpdir <- getTemporaryDirectory - ; let dflags1 = setTmpDir tmpdir dflags0 - -- On Windows, mingw is distributed with GHC, - -- so we look in TopDir/../mingw/bin ; let - gcc_prog - | isWindowsHost = installed_mingw_bin "gcc" - | otherwise = cGCC - perl_path - | isWindowsHost = installed_perl_bin cGHC_PERL - | otherwise = cGHC_PERL -- 'touch' is a GHC util for Windows touch_path | isWindowsHost = installed cGHC_TOUCHY_PGM @@ -225,26 +235,42 @@ initSysTools mbMinusB dflags0 ; let lc_prog = "llc" lo_prog = "opt" - ; return dflags1{ - ghcUsagePath = ghc_usage_msg_path, - ghciUsagePath = ghci_usage_msg_path, - topDir = top_dir, - systemPackageConfig = pkgconfig_path, - pgm_L = unlit_path, - pgm_P = cpp_path, - pgm_F = "", - pgm_c = (gcc_prog,[]), - pgm_s = (split_prog,split_args), - pgm_a = (as_prog,[]), - pgm_l = (ld_prog,[]), - pgm_dll = (mkdll_prog,mkdll_args), - pgm_T = touch_path, - pgm_sysman = top_dir ++ "/ghc/rts/parallel/SysMan", - pgm_windres = windres_path, - pgm_lo = (lo_prog,[]), - pgm_lc = (lc_prog,[]) + ; return $ Settings { + sTmpDir = normalise tmpdir, + sGhcUsagePath = ghc_usage_msg_path, + sGhciUsagePath = ghci_usage_msg_path, + sTopDir = top_dir, + sRawSettings = mySettings, + sExtraGccViaCFlags = words myExtraGccViaCFlags, + sSystemPackageConfig = pkgconfig_path, + sPgm_L = unlit_path, + sPgm_P = cpp_path, + sPgm_F = "", + sPgm_c = (gcc_prog,[]), + sPgm_s = (split_prog,split_args), + sPgm_a = (as_prog,[]), + sPgm_l = (ld_prog,[]), + sPgm_dll = (mkdll_prog,mkdll_args), + sPgm_T = touch_path, + sPgm_sysman = top_dir ++ "/ghc/rts/parallel/SysMan", + sPgm_windres = windres_path, + sPgm_lo = (lo_prog,[]), + sPgm_lc = (lc_prog,[]), -- Hans: this isn't right in general, but you can -- elaborate it in the same way as the others + sOpt_L = [], + sOpt_P = (if opt_PIC + then -- this list gets reversed + ["-D__PIC__", "-U __PIC__"] + else []), + sOpt_F = [], + sOpt_c = [], + sOpt_a = [], + sOpt_m = [], + sOpt_l = [], + sOpt_windres = [], + sOpt_lo = [], + sOpt_lc = [] } } \end{code} @@ -448,11 +474,6 @@ copyWithHeader dflags purpose maybe_header from to = do hClose hout hClose hin -getExtraViaCOpts :: DynFlags -> IO [String] -getExtraViaCOpts dflags = do - f <- readFile (topDir dflags "extra-gcc-opts") - return (words f) - -- | read the contents of the named section in an ELF object as a -- String. readElfSection :: DynFlags -> String -> FilePath -> IO (Maybe String) @@ -527,8 +548,9 @@ newTempName dflags extn -- return our temporary directory within tmp_dir, creating one if we -- don't have one yet getTempDir :: DynFlags -> IO FilePath -getTempDir dflags@(DynFlags{tmpDir=tmp_dir}) +getTempDir dflags = do let ref = dirsToClean dflags + tmp_dir = tmpDir dflags mapping <- readIORef ref case Map.lookup tmp_dir mapping of Nothing -> diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 5c41d72..a2d2276 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -1856,7 +1856,7 @@ pragState dynflags buf loc = (mkPState dynflags buf loc) { mkPState :: DynFlags -> StringBuffer -> SrcLoc -> PState mkPState flags buf loc = PState { - buffer = buf, + buffer = buf, dflags = flags, messages = emptyMessages, last_loc = mkSrcSpan loc loc, @@ -1873,34 +1873,34 @@ mkPState flags buf loc = alr_justClosedExplicitLetBlock = False } where - bitmap = genericsBit `setBitIf` xopt Opt_Generics flags - .|. ffiBit `setBitIf` xopt Opt_ForeignFunctionInterface flags - .|. parrBit `setBitIf` xopt Opt_ParallelArrays flags - .|. arrowsBit `setBitIf` xopt Opt_Arrows flags - .|. thBit `setBitIf` xopt Opt_TemplateHaskell flags - .|. qqBit `setBitIf` xopt Opt_QuasiQuotes flags - .|. ipBit `setBitIf` xopt Opt_ImplicitParams flags - .|. explicitForallBit `setBitIf` xopt Opt_ExplicitForAll flags - .|. bangPatBit `setBitIf` xopt Opt_BangPatterns flags - .|. tyFamBit `setBitIf` xopt Opt_TypeFamilies flags - .|. haddockBit `setBitIf` dopt Opt_Haddock flags - .|. magicHashBit `setBitIf` xopt Opt_MagicHash flags - .|. kindSigsBit `setBitIf` xopt Opt_KindSignatures flags - .|. recursiveDoBit `setBitIf` xopt Opt_RecursiveDo flags - .|. recBit `setBitIf` xopt Opt_DoRec flags - .|. recBit `setBitIf` xopt Opt_Arrows flags - .|. unicodeSyntaxBit `setBitIf` xopt Opt_UnicodeSyntax flags - .|. unboxedTuplesBit `setBitIf` xopt Opt_UnboxedTuples flags + bitmap = genericsBit `setBitIf` xopt Opt_Generics flags + .|. ffiBit `setBitIf` xopt Opt_ForeignFunctionInterface flags + .|. parrBit `setBitIf` xopt Opt_ParallelArrays flags + .|. arrowsBit `setBitIf` xopt Opt_Arrows flags + .|. thBit `setBitIf` xopt Opt_TemplateHaskell flags + .|. qqBit `setBitIf` xopt Opt_QuasiQuotes flags + .|. ipBit `setBitIf` xopt Opt_ImplicitParams flags + .|. explicitForallBit `setBitIf` xopt Opt_ExplicitForAll flags + .|. bangPatBit `setBitIf` xopt Opt_BangPatterns flags + .|. tyFamBit `setBitIf` xopt Opt_TypeFamilies flags + .|. haddockBit `setBitIf` dopt Opt_Haddock flags + .|. magicHashBit `setBitIf` xopt Opt_MagicHash flags + .|. kindSigsBit `setBitIf` xopt Opt_KindSignatures flags + .|. recursiveDoBit `setBitIf` xopt Opt_RecursiveDo flags + .|. recBit `setBitIf` xopt Opt_DoRec flags + .|. recBit `setBitIf` xopt Opt_Arrows flags + .|. unicodeSyntaxBit `setBitIf` xopt Opt_UnicodeSyntax flags + .|. unboxedTuplesBit `setBitIf` xopt Opt_UnboxedTuples flags .|. datatypeContextsBit `setBitIf` xopt Opt_DatatypeContexts flags .|. transformComprehensionsBit `setBitIf` xopt Opt_TransformListComp flags .|. rawTokenStreamBit `setBitIf` dopt Opt_KeepRawTokenStream flags .|. alternativeLayoutRuleBit `setBitIf` xopt Opt_AlternativeLayoutRule flags - .|. relaxedLayoutBit `setBitIf` xopt Opt_RelaxedLayout flags + .|. relaxedLayoutBit `setBitIf` xopt Opt_RelaxedLayout flags .|. nondecreasingIndentationBit `setBitIf` xopt Opt_NondecreasingIndentation flags -- setBitIf :: Int -> Bool -> Int b `setBitIf` cond | cond = bit b - | otherwise = 0 + | otherwise = 0 addWarning :: DynFlag -> SrcSpan -> SDoc -> P () addWarning option srcspan warning diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs index b37556b..8f2d21f 100644 --- a/compiler/prelude/PrelRules.lhs +++ b/compiler/prelude/PrelRules.lhs @@ -54,7 +54,7 @@ Well, of course you'd need a lot of rules if you did it like that, so we use a BuiltinRule instead, so that we can match in any two literal values. So the rule is really more like - (Lit 4) +# (Lit y) = Lit (x+#y) + (Lit x) +# (Lit y) = Lit (x+#y) where the (+#) on the rhs is done at compile time That is why these rules are built in here. Other rules diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index 6c57cb2..df3b12d 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -306,7 +306,10 @@ rnValBindsRHS trim mb_bound_names (ValBindsIn mbinds sigs) (anal_binds, anal_dus) -> return (valbind', valbind'_dus) where valbind' = ValBindsOut anal_binds sigs' - valbind'_dus = usesOnly (hsSigsFVs sigs') `plusDU` anal_dus + valbind'_dus = anal_dus `plusDU` usesOnly (hsSigsFVs sigs') + -- Put the sig uses *after* the bindings + -- so that the binders are removed from + -- the uses in the sigs } rnValBindsRHS _ _ b = pprPanic "rnValBindsRHS" (ppr b) @@ -699,7 +702,7 @@ renameSig _ (SpecInstSig ty) -- {-# SPECIALISE #-} pragmas can refer to imported Ids -- so, in the top-level case (when mb_names is Nothing) -- we use lookupOccRn. If there's both an imported and a local 'f' --- then the SPECIALISE pragma is ambiguous, unlike alll other signatures +-- then the SPECIALISE pragma is ambiguous, unlike all other signatures renameSig mb_names sig@(SpecSig v ty inl) = do { new_v <- case mb_names of Just {} -> lookupSigOccRn mb_names sig v diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index 97f4ab3..c4ad95a 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -12,7 +12,7 @@ module RnEnv ( lookupLocalDataTcNames, lookupSigOccRn, lookupFixityRn, lookupTyFixityRn, lookupInstDeclBndr, lookupSubBndr, lookupConstructorFields, - lookupSyntaxName, lookupSyntaxTable, + lookupSyntaxName, lookupSyntaxTable, lookupIfThenElse, lookupGreRn, lookupGreLocalRn, lookupGreRn_maybe, getLookupOccRn, addUsedRdrNames, @@ -754,6 +754,17 @@ We treat the orignal (standard) names as free-vars too, because the type checker checks the type of the user thing against the type of the standard thing. \begin{code} +lookupIfThenElse :: RnM (Maybe (SyntaxExpr Name), FreeVars) +-- Different to lookupSyntaxName because in the non-rebindable +-- case we desugar directly rather than calling an existing function +-- Hence the (Maybe (SyntaxExpr Name)) return type +lookupIfThenElse + = do { rebind <- xoptM Opt_RebindableSyntax + ; if not rebind + then return (Nothing, emptyFVs) + else do { ite <- lookupOccRn (mkVarUnqual (fsLit "ifThenElse")) + ; return (Just (HsVar ite), unitFV ite) } } + lookupSyntaxName :: Name -- The standard name -> RnM (SyntaxExpr Name, FreeVars) -- Possibly a non-standard name lookupSyntaxName std_name diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index 9bb9551..d11249a 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -268,13 +268,10 @@ rnExpr (ExprWithTySig expr pty) rnExpr (HsIf _ p b1 b2) = do { (p', fvP) <- rnLExpr p - ; (b1', fvB1) <- rnLExpr b1 - ; (b2', fvB2) <- rnLExpr b2 - ; rebind <- xoptM Opt_RebindableSyntax - ; if not rebind - then return (HsIf Nothing p' b1' b2', plusFVs [fvP, fvB1, fvB2]) - else do { c <- liftM HsVar (lookupOccRn (mkVarUnqual (fsLit "ifThenElse"))) - ; return (HsIf (Just c) p' b1' b2', plusFVs [fvP, fvB1, fvB2]) }} + ; (b1', fvB1) <- rnLExpr b1 + ; (b2', fvB2) <- rnLExpr b2 + ; (mb_ite, fvITE) <- lookupIfThenElse + ; return (HsIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) } rnExpr (HsType a) = rnHsTypeFVs doc a `thenM` \ (t, fvT) -> diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 725baeb..18c2dfd 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -1252,4 +1252,4 @@ add_bind _ (ValBindsOut {}) = panic "RdrHsSyn:add_bind" add_sig :: LSig a -> HsValBinds a -> HsValBinds a add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs) add_sig _ (ValBindsOut {}) = panic "RdrHsSyn:add_sig" -\end{code} \ No newline at end of file +\end{code} diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 8249c89..db84c90 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -1237,10 +1237,10 @@ completeCall env var cont | not (dopt Opt_D_dump_inlinings dflags) = stuff | not (dopt Opt_D_verbose_core2core dflags) = if isExternalName (idName var) then - pprTrace "Inlining done:" (ppr var) stuff + pprDefiniteTrace "Inlining done:" (ppr var) stuff else stuff | otherwise - = pprTrace ("Inlining done: " ++ showSDoc (ppr var)) + = pprDefiniteTrace ("Inlining done: " ++ showSDoc (ppr var)) (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding), text "Cont: " <+> ppr cont]) stuff @@ -1393,10 +1393,10 @@ tryRules env rules fn args call_cont , not (dopt Opt_D_dump_rule_rewrites dflags) = stuff | not (dopt Opt_D_dump_rule_rewrites dflags) - = pprTrace "Rule fired:" (ftext (ru_name rule)) stuff + = pprDefiniteTrace "Rule fired:" (ftext (ru_name rule)) stuff | otherwise - = pprTrace "Rule fired" + = pprDefiniteTrace "Rule fired" (vcat [text "Rule:" <+> ftext (ru_name rule), text "Before:" <+> hang (ppr fn) 2 (sep (map pprParendExpr args)), text "After: " <+> pprCoreExpr rule_rhs, diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index 8a6a3b7..33e9081 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -25,7 +25,6 @@ import TcHsType import TcPat import TcMType import TcType -import RnBinds( misplacedSigErr ) import Coercion import TysPrim import Id @@ -44,7 +43,6 @@ import BasicTypes import Outputable import FastString -import Data.List( partition ) import Control.Monad #include "HsVersions.h" @@ -559,24 +557,16 @@ tcSpec _ prag = pprPanic "tcSpec" (ppr prag) tcImpPrags :: [LSig Name] -> TcM [LTcSpecPrag] tcImpPrags prags = do { this_mod <- getModule - ; let is_imp prag - = case sigName prag of - Nothing -> False - Just name -> not (nameIsLocalOrFrom this_mod name) - (spec_prags, others) = partition isSpecLSig $ - filter is_imp prags - ; mapM_ misplacedSigErr others - -- Messy that this misplaced-sig error comes here - -- but the others come from the renamer - ; mapAndRecoverM (wrapLocM tcImpSpec) spec_prags } - -tcImpSpec :: Sig Name -> TcM TcSpecPrag -tcImpSpec prag@(SpecSig (L _ name) _ _) + ; mapAndRecoverM (wrapLocM tcImpSpec) + [L loc (name,prag) | (L loc prag@(SpecSig (L _ name) _ _)) <- prags + , not (nameIsLocalOrFrom this_mod name) ] } + +tcImpSpec :: (Name, Sig Name) -> TcM TcSpecPrag +tcImpSpec (name, prag) = do { id <- tcLookupId name ; checkTc (isAnyInlinePragma (idInlinePragma id)) (impSpecErr name) ; tcSpec id prag } -tcImpSpec p = pprPanic "tcImpSpec" (ppr p) impSpecErr :: Name -> SDoc impSpecErr name diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 2988f08..1798be3 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -1282,7 +1282,7 @@ inferInstanceContexts oflag infer_specs gen_soln (DS { ds_loc = loc, ds_orig = orig, ds_tvs = tyvars , ds_cls = clas, ds_tys = inst_tys, ds_theta = deriv_rhs }) = setSrcSpan loc $ - addErrCtxt (derivInstCtxt clas inst_tys) $ + addErrCtxt (derivInstCtxt the_pred) $ do { -- Check for a bizarre corner case, when the derived instance decl should -- have form instance C a b => D (T a) where ... -- Note that 'b' isn't a parameter of T. This gives rise to all sorts @@ -1297,7 +1297,7 @@ inferInstanceContexts oflag infer_specs , not (tyVarsOfPred pred `subVarSet` tv_set)] ; mapM_ (addErrTc . badDerivedPred) weird_preds - ; theta <- simplifyDeriv orig tyvars deriv_rhs + ; theta <- simplifyDeriv orig the_pred tyvars deriv_rhs -- checkValidInstance tyvars theta clas inst_tys -- Not necessary; see Note [Exotic derived instance contexts] -- in TcSimplify @@ -1307,6 +1307,8 @@ inferInstanceContexts oflag infer_specs -- Hence no need to call: -- checkValidInstance tyvars theta clas inst_tys ; return (sortLe (<=) theta) } -- Canonicalise before returning the solution + where + the_pred = mkClassPred clas inst_tys ------------------------------------------------------------------ mkInstance :: OverlapFlag -> ThetaType -> DerivSpec -> Instance @@ -1511,9 +1513,9 @@ standaloneCtxt :: LHsType Name -> SDoc standaloneCtxt ty = hang (ptext (sLit "In the stand-alone deriving instance for")) 2 (quotes (ppr ty)) -derivInstCtxt :: Class -> [Type] -> Message -derivInstCtxt clas inst_tys - = ptext (sLit "When deriving the instance for") <+> parens (pprClassPred clas inst_tys) +derivInstCtxt :: PredType -> Message +derivInstCtxt pred + = ptext (sLit "When deriving the instance for") <+> parens (ppr pred) badDerivedPred :: PredType -> Message badDerivedPred pred diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs index f714943..645c43a 100644 --- a/compiler/typecheck/TcErrors.lhs +++ b/compiler/typecheck/TcErrors.lhs @@ -15,6 +15,7 @@ import TcMType import TcSMonad import TcType import TypeRep +import Type( isTyVarTy ) import Inst import InstEnv @@ -320,15 +321,10 @@ reportEqErr ctxt ty1 ty2 reportTyVarEqErr :: ReportErrCtxt -> TcTyVar -> TcType -> TcM () -- tv1 and ty2 are already tidied reportTyVarEqErr ctxt tv1 ty2 - | not is_meta1 - , Just tv2 <- tcGetTyVar_maybe ty2 - , isMetaTyVar tv2 - = -- sk ~ alpha: swap - reportTyVarEqErr ctxt tv2 ty1 - - | (not is_meta1) - = -- sk ~ ty, where ty isn't a meta-tyvar: mis-match - addErrorReport (addExtraInfo ctxt ty1 ty2) + | isSkolemTyVar tv1 -- ty2 won't be a meta-tyvar, or else the thing would + -- be oriented the other way round; see TcCanonical.reOrient + || isSigTyVar tv1 && not (isTyVarTy ty2) + = addErrorReport (addExtraInfo ctxt ty1 ty2) (misMatchOrCND ctxt ty1 ty2) -- So tv is a meta tyvar, and presumably it is @@ -376,21 +372,26 @@ reportTyVarEqErr ctxt tv1 ty2 , ptext (sLit "bound at") <+> ppr (ctLocOrigin implic_loc)] ; addErrorReport (addExtraInfo ctxt ty1 ty2) (msg $$ nest 2 extra) } - | otherwise -- This can happen, by a recursive decomposition of frozen - -- occurs check constraints - -- Example: alpha ~ T Int alpha has frozen. - -- Then alpha gets unified to T beta gamma - -- So now we have T beta gamma ~ T Int (T beta gamma) - -- Decompose to (beta ~ Int, gamma ~ T beta gamma) - -- The (gamma ~ T beta gamma) is the occurs check, but - -- the (beta ~ Int) isn't an error at all. So return () - = return () - + | otherwise + = pprTrace "reportTyVarEqErr" (ppr tv1 $$ ppr ty2 $$ ppr (cec_encl ctxt)) $ + return () + -- I don't think this should happen, and if it does I want to know + -- Trac #5130 happened because an actual type error was not + -- reported at all! So not reporting is pretty dangerous. + -- + -- OLD, OUT OF DATE COMMENT + -- This can happen, by a recursive decomposition of frozen + -- occurs check constraints + -- Example: alpha ~ T Int alpha has frozen. + -- Then alpha gets unified to T beta gamma + -- So now we have T beta gamma ~ T Int (T beta gamma) + -- Decompose to (beta ~ Int, gamma ~ T beta gamma) + -- The (gamma ~ T beta gamma) is the occurs check, but + -- the (beta ~ Int) isn't an error at all. So return () where - is_meta1 = isMetaTyVar tv1 - k1 = tyVarKind tv1 - k2 = typeKind ty2 - ty1 = mkTyVarTy tv1 + k1 = tyVarKind tv1 + k2 = typeKind ty2 + ty1 = mkTyVarTy tv1 mkTyFunInfoMsg :: TcType -> TcType -> SDoc -- See Note [Non-injective type functions] @@ -458,12 +459,22 @@ typeExtraInfoMsg :: [Implication] -> Type -> SDoc -- Shows a bit of extra info about skolem constants typeExtraInfoMsg implics ty | Just tv <- tcGetTyVar_maybe ty - , isTcTyVar tv - , isSkolemTyVar tv - = pprSkolTvBinding implics tv - where -typeExtraInfoMsg _ _ = empty -- Normal case - + , isTcTyVar tv, isSkolemTyVar tv + , let pp_tv = quotes (ppr tv) + = case tcTyVarDetails tv of + SkolemTv {} -> pp_tv <+> ppr_skol (getSkolemInfo implics tv) (getSrcLoc tv) + FlatSkol {} -> pp_tv <+> ptext (sLit "is a flattening type variable") + RuntimeUnk {} -> pp_tv <+> ptext (sLit "is an interactive-debugger skolem") + MetaTv {} -> empty + + | otherwise -- Normal case + = empty + + where + ppr_skol UnkSkol _ = ptext (sLit "is an unknown type variable") -- Unhelpful + ppr_skol info loc = sep [ptext (sLit "is a rigid type variable bound by"), + sep [ppr info, ptext (sLit "at") <+> ppr loc]] + -------------------- unifyCtxt :: EqOrigin -> TidyEnv -> TcM (TidyEnv, SDoc) unifyCtxt (UnifyOrigin { uo_actual = act_ty, uo_expected = exp_ty }) tidy_env @@ -659,7 +670,6 @@ mkMonomorphismMsg :: ReportErrCtxt -> [TcTyVar] -> TcM (TidyEnv, SDoc) -- ASSUMPTION: the Insts are fully zonked mkMonomorphismMsg ctxt inst_tvs = do { dflags <- getDOpts - ; traceTc "Mono" (vcat (map (pprSkolTvBinding (cec_encl ctxt)) inst_tvs)) ; (tidy_env, docs) <- findGlobals ctxt (mkVarSet inst_tvs) ; return (tidy_env, mk_msg dflags docs) } where @@ -685,28 +695,6 @@ monomorphism_fix dflags else empty] -- Only suggest adding "-XNoMonomorphismRestriction" -- if it is not already set! - -pprSkolTvBinding :: [Implication] -> TcTyVar -> SDoc --- Print info about the binding of a skolem tyvar, --- or nothing if we don't have anything useful to say -pprSkolTvBinding implics tv - | isTcTyVar tv = quotes (ppr tv) <+> ppr_details (tcTyVarDetails tv) - | otherwise = quotes (ppr tv) <+> ppr_skol (getSkolemInfo implics tv) - where - ppr_details (SkolemTv {}) = ppr_skol (getSkolemInfo implics tv) - ppr_details (FlatSkol {}) = ptext (sLit "is a flattening type variable") - ppr_details (RuntimeUnk {}) = ptext (sLit "is an interactive-debugger skolem") - ppr_details (MetaTv (SigTv n) _) = ptext (sLit "is bound by the type signature for") - <+> quotes (ppr n) - ppr_details (MetaTv _ _) = ptext (sLit "is a meta type variable") - - - ppr_skol UnkSkol = ptext (sLit "is an unknown type variable") -- Unhelpful - ppr_skol RuntimeUnkSkol = ptext (sLit "is an unknown runtime type") - ppr_skol info = sep [ptext (sLit "is a rigid type variable bound by"), - sep [ppr info, - ptext (sLit "at") <+> ppr (getSrcLoc tv)]] - getSkolemInfo :: [Implication] -> TcTyVar -> SkolemInfo getSkolemInfo [] tv = WARN( True, ptext (sLit "No skolem info:") <+> ppr tv ) diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs index 73fd449..8f53d6e 100644 --- a/compiler/typecheck/TcForeign.lhs +++ b/compiler/typecheck/TcForeign.lhs @@ -12,11 +12,11 @@ is restricted to what the outside world understands (read C), and this module checks to see if a foreign declaration has got a legal type. \begin{code} -module TcForeign - ( - tcForeignImports +module TcForeign + ( + tcForeignImports , tcForeignExports - ) where + ) where #include "HsVersions.h" @@ -43,18 +43,18 @@ import FastString -- Defines a binding isForeignImport :: LForeignDecl name -> Bool isForeignImport (L _ (ForeignImport _ _ _)) = True -isForeignImport _ = False +isForeignImport _ = False -- Exports a binding isForeignExport :: LForeignDecl name -> Bool isForeignExport (L _ (ForeignExport _ _ _)) = True -isForeignExport _ = False +isForeignExport _ = False \end{code} %************************************************************************ -%* * +%* * \subsection{Imports} -%* * +%* * %************************************************************************ \begin{code} @@ -64,22 +64,22 @@ tcForeignImports decls tcFImport :: ForeignDecl Name -> TcM (Id, ForeignDecl Id) tcFImport fo@(ForeignImport (L loc nm) hs_ty imp_decl) - = addErrCtxt (foreignDeclCtxt fo) $ - do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty - ; let - -- Drop the foralls before inspecting the - -- structure of the foreign type. - (_, t_ty) = tcSplitForAllTys sig_ty - (arg_tys, res_ty) = tcSplitFunTys t_ty - id = mkLocalId nm sig_ty - -- Use a LocalId to obey the invariant that locally-defined - -- things are LocalIds. However, it does not need zonking, - -- (so TcHsSyn.zonkForeignExports ignores it). - - ; imp_decl' <- tcCheckFIType sig_ty arg_tys res_ty imp_decl - -- Can't use sig_ty here because sig_ty :: Type and - -- we need HsType Id hence the undefined - ; return (id, ForeignImport (L loc id) undefined imp_decl') } + = addErrCtxt (foreignDeclCtxt fo) $ + do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty + ; let + -- Drop the foralls before inspecting the + -- structure of the foreign type. + (_, t_ty) = tcSplitForAllTys sig_ty + (arg_tys, res_ty) = tcSplitFunTys t_ty + id = mkLocalId nm sig_ty + -- Use a LocalId to obey the invariant that locally-defined + -- things are LocalIds. However, it does not need zonking, + -- (so TcHsSyn.zonkForeignExports ignores it). + + ; imp_decl' <- tcCheckFIType sig_ty arg_tys res_ty imp_decl + -- Can't use sig_ty here because sig_ty :: Type and + -- we need HsType Id hence the undefined + ; return (id, ForeignImport (L loc id) undefined imp_decl') } tcFImport d = pprPanic "tcFImport" (ppr d) \end{code} @@ -93,15 +93,15 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ safety _ (CLabel _)) do { checkCg checkCOrAsmOrLlvmOrInterp ; checkSafety safety ; check (isFFILabelTy res_ty) (illegalForeignTyErr empty sig_ty) - ; return idecl } -- NB check res_ty not sig_ty! - -- In case sig_ty is (forall a. ForeignPtr a) + ; return idecl } -- NB check res_ty not sig_ty! + -- In case sig_ty is (forall a. ForeignPtr a) tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ CWrapper) = do - -- Foreign wrapper (former f.e.d.) - -- The type must be of the form ft -> IO (FunPtr ft), where ft is a - -- valid foreign type. For legacy reasons ft -> IO (Ptr ft) as well - -- as ft -> IO Addr is accepted, too. The use of the latter two forms - -- is DEPRECATED, though. + -- Foreign wrapper (former f.e.d.) + -- The type must be of the form ft -> IO (FunPtr ft), where ft is a + -- valid foreign type. For legacy reasons ft -> IO (Ptr ft) as well + -- as ft -> IO Addr is accepted, too. The use of the latter two forms + -- is DEPRECATED, though. checkCg checkCOrAsmOrLlvmOrInterp checkCConv cconv checkSafety safety @@ -174,14 +174,14 @@ checkMissingAmpersand dflags arg_tys res_ty \end{code} %************************************************************************ -%* * +%* * \subsection{Exports} -%* * +%* * %************************************************************************ \begin{code} -tcForeignExports :: [LForeignDecl Name] - -> TcM (LHsBinds TcId, [LForeignDecl TcId]) +tcForeignExports :: [LForeignDecl Name] + -> TcM (LHsBinds TcId, [LForeignDecl TcId]) tcForeignExports decls = foldlM combine (emptyLHsBinds, []) (filter isForeignExport decls) where @@ -190,25 +190,25 @@ tcForeignExports decls return (b `consBag` binds, f:fs) tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id) -tcFExport fo@(ForeignExport (L loc nm) hs_ty spec) = - addErrCtxt (foreignDeclCtxt fo) $ do +tcFExport fo@(ForeignExport (L loc nm) hs_ty spec) + = addErrCtxt (foreignDeclCtxt fo) $ do - sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty - rhs <- tcPolyExpr (nlHsVar nm) sig_ty + sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty + rhs <- tcPolyExpr (nlHsVar nm) sig_ty - tcCheckFEType sig_ty spec + tcCheckFEType sig_ty spec - -- we're exporting a function, but at a type possibly more - -- constrained than its declared/inferred type. Hence the need - -- to create a local binding which will call the exported function - -- at a particular type (and, maybe, overloading). + -- we're exporting a function, but at a type possibly more + -- constrained than its declared/inferred type. Hence the need + -- to create a local binding which will call the exported function + -- at a particular type (and, maybe, overloading). - -- We need to give a name to the new top-level binding that - -- is *stable* (i.e. the compiler won't change it later), - -- because this name will be referred to by the C code stub. - id <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc - return (mkVarBind id rhs, ForeignExport (L loc id) undefined spec) + -- We need to give a name to the new top-level binding that + -- is *stable* (i.e. the compiler won't change it later), + -- because this name will be referred to by the C code stub. + id <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc + return (mkVarBind id rhs, ForeignExport (L loc id) undefined spec) tcFExport d = pprPanic "tcFExport" (ppr d) \end{code} @@ -232,9 +232,9 @@ tcCheckFEType sig_ty (CExport (CExportStatic str cconv)) = do %************************************************************************ -%* * +%* * \subsection{Miscellaneous} -%* * +%* * %************************************************************************ \begin{code} @@ -246,7 +246,7 @@ checkForeignArgs pred tys go ty = check (pred ty) (illegalForeignTyErr argument ty) ------------ Checking result types for foreign calls ---------------------- --- Check that the type has the form +-- Check that the type has the form -- (IO t) or (t) , and that t satisfies the given predicate. -- checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM () @@ -256,14 +256,14 @@ nonIOok = True mustBeIO = False checkForeignRes non_io_result_ok pred_res_ty ty - -- (IO t) is ok, and so is any newtype wrapping thereof + -- (IO t) is ok, and so is any newtype wrapping thereof | Just (_, res_ty, _) <- tcSplitIOType_maybe ty, pred_res_ty res_ty = return () - + | otherwise - = check (non_io_result_ok && pred_res_ty ty) - (illegalForeignTyErr result ty) + = check (non_io_result_ok && pred_res_ty ty) + (illegalForeignTyErr result ty) \end{code} \begin{code} @@ -272,7 +272,7 @@ checkCOrAsmOrLlvm HscC = Nothing checkCOrAsmOrLlvm HscAsm = Nothing checkCOrAsmOrLlvm HscLlvm = Nothing checkCOrAsmOrLlvm _ - = Just (text "requires via-C, llvm (-fllvm) or native code generation (-fvia-C)") + = Just (text "requires via-C, llvm (-fllvm) or native code generation (-fvia-C)") checkCOrAsmOrLlvmOrInterp :: HscTarget -> Maybe SDoc checkCOrAsmOrLlvmOrInterp HscC = Nothing @@ -280,7 +280,7 @@ checkCOrAsmOrLlvmOrInterp HscAsm = Nothing checkCOrAsmOrLlvmOrInterp HscLlvm = Nothing checkCOrAsmOrLlvmOrInterp HscInterpreted = Nothing checkCOrAsmOrLlvmOrInterp _ - = Just (text "requires interpreted, C, Llvm or native code generation") + = Just (text "requires interpreted, C, Llvm or native code generation") checkCOrAsmOrLlvmOrDotNetOrInterp :: HscTarget -> Maybe SDoc checkCOrAsmOrLlvmOrDotNetOrInterp HscC = Nothing @@ -288,33 +288,33 @@ checkCOrAsmOrLlvmOrDotNetOrInterp HscAsm = Nothing checkCOrAsmOrLlvmOrDotNetOrInterp HscLlvm = Nothing checkCOrAsmOrLlvmOrDotNetOrInterp HscInterpreted = Nothing checkCOrAsmOrLlvmOrDotNetOrInterp _ - = Just (text "requires interpreted, C, Llvm or native code generation") + = Just (text "requires interpreted, C, Llvm or native code generation") checkCg :: (HscTarget -> Maybe SDoc) -> TcM () checkCg check = do - dflags <- getDOpts - let target = hscTarget dflags - case target of - HscNothing -> return () - _ -> - case check target of - Nothing -> return () - Just err -> addErrTc (text "Illegal foreign declaration:" <+> err) + dflags <- getDOpts + let target = hscTarget dflags + case target of + HscNothing -> return () + _ -> + case check target of + Nothing -> return () + Just err -> addErrTc (text "Illegal foreign declaration:" <+> err) \end{code} - + Calling conventions \begin{code} checkCConv :: CCallConv -> TcM () -checkCConv CCallConv = return () +checkCConv CCallConv = return () #if i386_TARGET_ARCH -checkCConv StdCallConv = return () +checkCConv StdCallConv = return () #else -- This is a warning, not an error. see #3336 -checkCConv StdCallConv = addWarnTc (text "the 'stdcall' calling convention is unsupported on this platform,"$$ text "treating as ccall") +checkCConv StdCallConv = addWarnTc (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall") #endif checkCConv PrimCallConv = addErrTc (text "The `prim' calling convention can only be used with `foreign import'") -checkCConv CmmCallConv = panic "checkCConv CmmCallConv" +checkCConv CmmCallConv = panic "checkCConv CmmCallConv" \end{code} Deprecated "threadsafe" calls @@ -329,12 +329,12 @@ Warnings \begin{code} check :: Bool -> Message -> TcM () -check True _ = return () +check True _ = return () check _ the_err = addErrTc the_err illegalForeignTyErr :: SDoc -> Type -> SDoc illegalForeignTyErr arg_or_res ty - = hang (hsep [ptext (sLit "Unacceptable"), arg_or_res, + = hang (hsep [ptext (sLit "Unacceptable"), arg_or_res, ptext (sLit "type in foreign declaration:")]) 2 (hsep [ppr ty]) @@ -344,12 +344,11 @@ argument = text "argument" result = text "result" badCName :: CLabelString -> Message -badCName target - = sep [quotes (ppr target) <+> ptext (sLit "is not a valid C identifier")] +badCName target + = sep [quotes (ppr target) <+> ptext (sLit "is not a valid C identifier")] foreignDeclCtxt :: ForeignDecl Name -> SDoc foreignDeclCtxt fo = hang (ptext (sLit "When checking declaration:")) 2 (ppr fo) \end{code} - diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index 2c04cf4..efacac2 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -893,15 +893,15 @@ gen_Read_binds get_fixity loc tycon read_nullary_cons = case nullary_cons of [] -> [] - [con] -> [nlHsDo DoExpr [bindLex (match_con con)] (result_expr con [])] + [con] -> [nlHsDo DoExpr (match_con con) (result_expr con [])] _ -> [nlHsApp (nlHsVar choose_RDR) (nlList (map mk_pair nullary_cons))] -- NB For operators the parens around (:=:) are matched by the -- enclosing "parens" call, so here we must match the naked -- data_con_str con - match_con con | isSym con_str = symbol_pat con_str - | otherwise = ident_pat con_str + match_con con | isSym con_str = [symbol_pat con_str] + | otherwise = ident_h_pat con_str where con_str = data_con_str con -- For nullary constructors we must match Ident s for normal constrs @@ -925,12 +925,12 @@ gen_Read_binds get_fixity loc tycon prefix_parser = mk_parser prefix_prec prefix_stmts body read_prefix_con - | isSym con_str = [read_punc "(", bindLex (symbol_pat con_str), read_punc ")"] - | otherwise = [bindLex (ident_pat con_str)] + | isSym con_str = [read_punc "(", symbol_pat con_str, read_punc ")"] + | otherwise = ident_h_pat con_str read_infix_con - | isSym con_str = [bindLex (symbol_pat con_str)] - | otherwise = [read_punc "`", bindLex (ident_pat con_str), read_punc "`"] + | isSym con_str = [symbol_pat con_str] + | otherwise = [read_punc "`"] ++ ident_h_pat con_str ++ [read_punc "`"] prefix_stmts -- T a b c = read_prefix_con ++ read_args @@ -972,8 +972,15 @@ gen_Read_binds get_fixity loc tycon result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as) punc_pat s = nlConPat punc_RDR [nlLitPat (mkHsString s)] -- Punc 'c' - ident_pat s = nlConPat ident_RDR [nlLitPat (mkHsString s)] -- Ident "foo" - symbol_pat s = nlConPat symbol_RDR [nlLitPat (mkHsString s)] -- Symbol ">>" + + -- For constructors and field labels ending in '#', we hackily + -- let the lexer generate two tokens, and look for both in sequence + -- Thus [Ident "I"; Symbol "#"]. See Trac #5041 + ident_h_pat s | Just (ss, '#') <- snocView s = [ ident_pat ss, symbol_pat "#" ] + | otherwise = [ ident_pat s ] + + ident_pat s = bindLex $ nlConPat ident_RDR [nlLitPat (mkHsString s)] -- Ident "foo" <- lexP + symbol_pat s = bindLex $ nlConPat symbol_RDR [nlLitPat (mkHsString s)] -- Symbol ">>" <- lexP data_con_str con = occNameString (getOccName con) @@ -991,11 +998,9 @@ gen_Read_binds get_fixity loc tycon -- or (#) = 4 -- Note the parens! read_lbl lbl | isSym lbl_str - = [read_punc "(", - bindLex (symbol_pat lbl_str), - read_punc ")"] + = [read_punc "(", symbol_pat lbl_str, read_punc ")"] | otherwise - = [bindLex (ident_pat lbl_str)] + = ident_h_pat lbl_str where lbl_str = occNameString (getOccName lbl) \end{code} diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs index 7453334..1d163aa 100644 --- a/compiler/typecheck/TcMType.lhs +++ b/compiler/typecheck/TcMType.lhs @@ -34,8 +34,8 @@ module TcMType ( -------------------------------- -- Instantiation - tcInstTyVar, tcInstTyVars, tcInstSigTyVars, - tcInstType, instMetaTyVar, + tcInstTyVars, tcInstSigTyVars, + tcInstType, tcInstSkolTyVars, tcInstSuperSkolTyVars, tcInstSkolTyVar, tcInstSkolType, tcSkolDFunType, tcSuperSkolTyVars, @@ -258,8 +258,17 @@ tcInstSkolType ty = tcInstType tcInstSkolTyVars ty tcInstSigTyVars :: [TyVar] -> TcM [TcTyVar] -- Make meta SigTv type variables for patten-bound scoped type varaibles -- We use SigTvs for them, so that they can't unify with arbitrary types -tcInstSigTyVars = mapM (\tv -> instMetaTyVar (SigTv (tyVarName tv)) tv) - -- ToDo: the "function binding site is bogus +tcInstSigTyVars = mapM tcInstSigTyVar + +tcInstSigTyVar :: TyVar -> TcM TcTyVar +tcInstSigTyVar tyvar + = do { uniq <- newMetaUnique + ; ref <- newMutVar Flexi + ; let name = setNameUnique (tyVarName tyvar) uniq + -- Use the same OccName so that the tidy-er + -- doesn't rename 'a' to 'a0' etc + kind = tyVarKind tyvar + ; return (mkTcTyVar name kind (MetaTv SigTv ref)) } \end{code} @@ -277,9 +286,9 @@ newMetaTyVar meta_info kind ; ref <- newMutVar Flexi ; let name = mkTcTyVarName uniq s s = case meta_info of - TauTv -> fsLit "t" - TcsTv -> fsLit "u" - SigTv _ -> fsLit "a" + TauTv -> fsLit "t" + TcsTv -> fsLit "u" + SigTv -> fsLit "a" ; return (mkTcTyVar name kind (MetaTv meta_info ref)) } mkTcTyVarName :: Unique -> FastString -> Name @@ -287,16 +296,6 @@ mkTcTyVarName :: Unique -> FastString -> Name -- leaving the un-cluttered names free for user names mkTcTyVarName uniq str = mkSysTvName uniq str -instMetaTyVar :: MetaInfo -> TyVar -> TcM TcTyVar --- Make a new meta tyvar whose Name and Kind --- come from an existing TyVar -instMetaTyVar meta_info tyvar - = do { uniq <- newMetaUnique - ; ref <- newMutVar Flexi - ; let name = mkSystemName uniq (getOccName tyvar) - kind = tyVarKind tyvar - ; return (mkTcTyVar name kind (MetaTv meta_info ref)) } - readMetaTyVar :: TyVar -> TcM MetaDetails readMetaTyVar tyvar = ASSERT2( isMetaTyVar tyvar, ppr tyvar ) readMutVar (metaTvRef tyvar) @@ -394,10 +393,6 @@ newFlexiTyVarTy kind = do newFlexiTyVarTys :: Int -> Kind -> TcM [TcType] newFlexiTyVarTys n kind = mapM newFlexiTyVarTy (nOfThem n kind) -tcInstTyVar :: TyVar -> TcM TcTyVar --- Instantiate with a META type variable -tcInstTyVar tyvar = instMetaTyVar TauTv tyvar - tcInstTyVars :: [TyVar] -> TcM ([TcTyVar], [TcType], TvSubst) -- Instantiate with META type variables tcInstTyVars tyvars @@ -407,6 +402,16 @@ tcInstTyVars tyvars -- Since the tyvars are freshly made, -- they cannot possibly be captured by -- any existing for-alls. Hence zipTopTvSubst + +tcInstTyVar :: TyVar -> TcM TcTyVar +-- Make a new unification variable tyvar whose Name and Kind +-- come from an existing TyVar +tcInstTyVar tyvar + = do { uniq <- newMetaUnique + ; ref <- newMutVar Flexi + ; let name = mkSystemName uniq (getOccName tyvar) + kind = tyVarKind tyvar + ; return (mkTcTyVar name kind (MetaTv TauTv ref)) } \end{code} diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index 3367f06..fc82729 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -639,7 +639,7 @@ plusImportAvails (ImportAvails { imp_mods = mods2, imp_dep_mods = dmods2, imp_dep_pkgs = dpkgs2, imp_orphs = orphs2, imp_finsts = finsts2 }) - = ImportAvails { imp_mods = plusModuleEnv_C (++) mods1 mods2, + = ImportAvails { imp_mods = plusModuleEnv_C (++) mods1 mods2, imp_dep_mods = plusUFM_C plus_mod_dep dmods1 dmods2, imp_dep_pkgs = dpkgs1 `unionLists` dpkgs2, imp_orphs = orphs1 `unionLists` orphs2, @@ -1038,9 +1038,6 @@ data SkolemInfo -- polymorphic Ids, and are now checking that their RHS -- constraints are satisfied. - | RuntimeUnkSkol -- a type variable used to represent an unknown - -- runtime type (used in the GHCi debugger) - | BracketSkol -- Template Haskell bracket | UnkSkol -- Unhelpful info (until I improve it) @@ -1075,8 +1072,7 @@ pprSkolInfo (InferSkol ids) = sep [ ptext (sLit "the inferred type of") -- UnkSkol -- For type variables the others are dealt with by pprSkolTvBinding. -- For Insts, these cases should not happen -pprSkolInfo UnkSkol = WARN( True, text "pprSkolInfo: UnkSkol" ) ptext (sLit "UnkSkol") -pprSkolInfo RuntimeUnkSkol = WARN( True, text "pprSkolInfo: RuntimeUnkSkol" ) ptext (sLit "RuntimeUnkSkol") +pprSkolInfo UnkSkol = WARN( True, text "pprSkolInfo: UnkSkol" ) ptext (sLit "UnkSkol") \end{code} diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs index 87cd5eb..647f22f 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.lhs @@ -103,7 +103,9 @@ import HsBinds -- for TcEvBinds stuff import Id import TcRnTypes - +#ifdef DEBUG +import Control.Monad( when ) +#endif import Data.IORef \end{code} @@ -421,17 +423,16 @@ type TcsUntouchables = (Untouchables,TcTyVarSet) \begin{code} data SimplContext - = SimplInfer -- Inferring type of a let-bound thing - | SimplRuleLhs -- Inferring type of a RULE lhs - | SimplInteractive -- Inferring type at GHCi prompt - | SimplCheck -- Checking a type signature or RULE rhs - deriving Eq + = SimplInfer SDoc -- Inferring type of a let-bound thing + | SimplRuleLhs RuleName -- Inferring type of a RULE lhs + | SimplInteractive -- Inferring type at GHCi prompt + | SimplCheck SDoc -- Checking a type signature or RULE rhs instance Outputable SimplContext where - ppr SimplInfer = ptext (sLit "SimplInfer") - ppr SimplRuleLhs = ptext (sLit "SimplRuleLhs") + ppr (SimplInfer d) = ptext (sLit "SimplInfer") <+> d + ppr (SimplCheck d) = ptext (sLit "SimplCheck") <+> d + ppr (SimplRuleLhs n) = ptext (sLit "SimplRuleLhs") <+> doubleQuotes (ftext n) ppr SimplInteractive = ptext (sLit "SimplInteractive") - ppr SimplCheck = ptext (sLit "SimplCheck") isInteractive :: SimplContext -> Bool isInteractive SimplInteractive = True @@ -441,14 +442,14 @@ simplEqsOnly :: SimplContext -> Bool -- Simplify equalities only, not dictionaries -- This is used for the LHS of rules; ee -- Note [Simplifying RULE lhs constraints] in TcSimplify -simplEqsOnly SimplRuleLhs = True -simplEqsOnly _ = False +simplEqsOnly (SimplRuleLhs {}) = True +simplEqsOnly _ = False performDefaulting :: SimplContext -> Bool -performDefaulting SimplInfer = False -performDefaulting SimplRuleLhs = False -performDefaulting SimplInteractive = True -performDefaulting SimplCheck = True +performDefaulting (SimplInfer {}) = False +performDefaulting (SimplRuleLhs {}) = False +performDefaulting SimplInteractive = True +performDefaulting (SimplCheck {}) = True --------------- newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a } @@ -526,7 +527,9 @@ runTcS context untouch tcs #ifdef DEBUG ; count <- TcM.readTcRef step_count - ; TcM.dumpTcRn (ptext (sLit "Constraint solver steps =") <+> int count) + ; when (count > 0) $ + TcM.debugDumpTcRn (ptext (sLit "Constraint solver steps =") + <+> int count <+> ppr context) #endif -- And return ; ev_binds <- TcM.readTcRef evb_ref @@ -563,8 +566,9 @@ recoverTcS (TcS recovery_code) (TcS thing_inside) ctxtUnderImplic :: SimplContext -> SimplContext -- See Note [Simplifying RULE lhs constraints] in TcSimplify -ctxtUnderImplic SimplRuleLhs = SimplCheck -ctxtUnderImplic ctxt = ctxt +ctxtUnderImplic (SimplRuleLhs n) = SimplCheck (ptext (sLit "lhs of rule") + <+> doubleQuotes (ftext n)) +ctxtUnderImplic ctxt = ctxt tryTcS :: TcS a -> TcS a -- Like runTcS, but from within the TcS monad diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index eecfb27..cf41372 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -49,7 +49,7 @@ simplifyTop :: WantedConstraints -> TcM (Bag EvBind) -- but when there is nothing to quantify we don't wrap -- in a degenerate implication, so we do that here instead simplifyTop wanteds - = simplifyCheck SimplCheck wanteds + = simplifyCheck (SimplCheck (ptext (sLit "top level"))) wanteds ------------------ simplifyInteractive :: WantedConstraints -> TcM (Bag EvBind) @@ -61,7 +61,8 @@ simplifyDefault :: ThetaType -- Wanted; has no type variables in it -> TcM () -- Succeeds iff the constraint is soluble simplifyDefault theta = do { wanted <- newFlatWanteds DefaultOrigin theta - ; _ignored_ev_binds <- simplifyCheck SimplCheck (mkFlatWC wanted) + ; _ignored_ev_binds <- simplifyCheck (SimplCheck (ptext (sLit "defaults"))) + (mkFlatWC wanted) ; return () } \end{code} @@ -75,13 +76,14 @@ simplifyDefault theta \begin{code} simplifyDeriv :: CtOrigin - -> [TyVar] - -> ThetaType -- Wanted - -> TcM ThetaType -- Needed + -> PredType + -> [TyVar] + -> ThetaType -- Wanted + -> TcM ThetaType -- Needed -- Given instance (wanted) => C inst_ty -- Simplify 'wanted' as much as possibles -- Fail if not possible -simplifyDeriv orig tvs theta +simplifyDeriv orig pred tvs theta = do { tvs_skols <- tcInstSkolTyVars tvs -- Skolemize -- The constraint solving machinery -- expects *TcTyVars* not TyVars. @@ -90,12 +92,13 @@ simplifyDeriv orig tvs theta ; let skol_subst = zipTopTvSubst tvs $ map mkTyVarTy tvs_skols subst_skol = zipTopTvSubst tvs_skols $ map mkTyVarTy tvs + doc = parens $ ptext (sLit "deriving") <+> parens (ppr pred) ; wanted <- newFlatWanteds orig (substTheta skol_subst theta) ; traceTc "simplifyDeriv" (ppr tvs $$ ppr theta $$ ppr wanted) ; (residual_wanted, _binds) - <- runTcS SimplInfer NoUntouchables $ + <- runTcS (SimplInfer doc) NoUntouchables $ solveWanteds emptyInert (mkFlatWC wanted) ; let (good, bad) = partitionBagWith get_good (wc_flat residual_wanted) @@ -247,7 +250,7 @@ simplifyInfer top_lvl apply_mr name_taus wanteds -- Step 2 -- Now simplify the possibly-bound constraints ; (simpl_results, tc_binds0) - <- runTcS SimplInfer NoUntouchables $ + <- runTcS (SimplInfer (ppr (map fst name_taus))) NoUntouchables $ simplifyWithApprox (zonked_wanteds { wc_flat = perhaps_bound }) ; when (insolubleWC simpl_results) -- Fail fast if there is an insoluble constraint @@ -547,7 +550,7 @@ simplifyRule name tv_bndrs lhs_wanted rhs_wanted -- variables; hence *no untouchables* ; (lhs_results, lhs_binds) - <- runTcS SimplRuleLhs untch $ + <- runTcS (SimplRuleLhs name) untch $ solveWanteds emptyInert zonked_lhs ; traceTc "simplifyRule" $ @@ -589,7 +592,8 @@ simplifyRule name tv_bndrs lhs_wanted rhs_wanted -- Hence the rather painful ad-hoc treatement here ; rhs_binds_var@(EvBindsVar evb_ref _) <- newTcEvBinds - ; rhs_binds1 <- simplifyCheck SimplCheck $ + ; let doc = ptext (sLit "rhs of rule") <+> doubleQuotes (ftext name) + ; rhs_binds1 <- simplifyCheck (SimplCheck doc) $ WC { wc_flat = emptyBag , wc_insol = emptyBag , wc_impl = unitBag $ diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index eab0732..d9166d1 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -306,14 +306,12 @@ data MetaInfo -- A TauTv is always filled in with a tau-type, which -- never contains any ForAlls - | SigTv Name -- A variant of TauTv, except that it should not be + | SigTv -- A variant of TauTv, except that it should not be -- unified with a type, only with a type variable -- SigTvs are only distinguished to improve error messages -- see Note [Signature skolems] -- The MetaDetails, if filled in, will -- always be another SigTv or a SkolemTv - -- The Name is the name of the function from whose - -- type signature we got this skolem | TcsTv -- A MetaTv allocated by the constraint solver -- Its particular property is that it is always "touchable" @@ -392,12 +390,12 @@ kind_var_occ = mkOccName tvName "k" \begin{code} pprTcTyVarDetails :: TcTyVarDetails -> SDoc -- For debugging -pprTcTyVarDetails (SkolemTv {}) = ptext (sLit "sk") -pprTcTyVarDetails (RuntimeUnk {}) = ptext (sLit "rt") -pprTcTyVarDetails (FlatSkol {}) = ptext (sLit "fsk") -pprTcTyVarDetails (MetaTv TauTv _) = ptext (sLit "tau") -pprTcTyVarDetails (MetaTv TcsTv _) = ptext (sLit "tcs") -pprTcTyVarDetails (MetaTv (SigTv _) _) = ptext (sLit "sig") +pprTcTyVarDetails (SkolemTv {}) = ptext (sLit "sk") +pprTcTyVarDetails (RuntimeUnk {}) = ptext (sLit "rt") +pprTcTyVarDetails (FlatSkol {}) = ptext (sLit "fsk") +pprTcTyVarDetails (MetaTv TauTv _) = ptext (sLit "tau") +pprTcTyVarDetails (MetaTv TcsTv _) = ptext (sLit "tcs") +pprTcTyVarDetails (MetaTv SigTv _) = ptext (sLit "sig") pprUserTypeCtxt :: UserTypeCtxt -> SDoc pprUserTypeCtxt (FunSigCtxt n) = ptext (sLit "the type signature for") <+> quotes (ppr n) @@ -552,8 +550,8 @@ isTyConableTyVar tv -- not a SigTv = ASSERT( isTcTyVar tv) case tcTyVarDetails tv of - MetaTv (SigTv _) _ -> False - _ -> True + MetaTv SigTv _ -> False + _ -> True isSkolemTyVar tv = ASSERT2( isTcTyVar tv, ppr tv ) @@ -583,8 +581,8 @@ isSigTyVar :: Var -> Bool isSigTyVar tv = ASSERT( isTcTyVar tv ) case tcTyVarDetails tv of - MetaTv (SigTv _) _ -> True - _ -> False + MetaTv SigTv _ -> True + _ -> False metaTvRef :: TyVar -> IORef MetaDetails metaTvRef tv diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs index 4fc50b3..31352e1 100644 --- a/compiler/typecheck/TcUnify.lhs +++ b/compiler/typecheck/TcUnify.lhs @@ -899,8 +899,8 @@ uUnfilledVars origin swapped tv1 details1 tv2 details2 ty1 = mkTyVarTy tv1 ty2 = mkTyVarTy tv2 - nicer_to_update_tv1 _ (SigTv _) = True - nicer_to_update_tv1 (SigTv _) _ = False + nicer_to_update_tv1 _ SigTv = True + nicer_to_update_tv1 SigTv _ = False nicer_to_update_tv1 _ _ = isSystemName (Var.varName tv1) -- Try not to update SigTvs; and try to update sys-y type -- variables in preference to ones gotten (say) by diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs index 8551409..7fdf4ae 100644 --- a/compiler/types/TypeRep.lhs +++ b/compiler/types/TypeRep.lhs @@ -485,9 +485,7 @@ pprKind = pprType pprParendKind = pprParendType ppr_type :: Prec -> Type -> SDoc -ppr_type _ (TyVarTy tv) -- Note [Infix type variables] - | isSymOcc (getOccName tv) = parens (ppr tv) - | otherwise = ppr tv +ppr_type _ (TyVarTy tv) = ppr_tvar tv ppr_type p (PredTy pred) = maybeParen p TyConPrec $ ifPprDebug (ptext (sLit "")) <> (ppr pred) ppr_type p (TyConApp tc tys) = ppr_tc_app p tc tys @@ -570,14 +568,19 @@ ppr_tc tc else ptext (sLit "")) | otherwise = empty +ppr_tvar :: TyVar -> SDoc +ppr_tvar tv -- Note [Infix type variables] + | isSymOcc (getOccName tv) = parens (ppr tv) + | otherwise = ppr tv + ------------------- pprForAll :: [TyVar] -> SDoc pprForAll [] = empty pprForAll tvs = ptext (sLit "forall") <+> sep (map pprTvBndr tvs) <> dot pprTvBndr :: TyVar -> SDoc -pprTvBndr tv | isLiftedTypeKind kind = ppr tv - | otherwise = parens (ppr tv <+> dcolon <+> pprKind kind) +pprTvBndr tv | isLiftedTypeKind kind = ppr_tvar tv + | otherwise = parens (ppr_tvar tv <+> dcolon <+> pprKind kind) where kind = tyVarKind tv \end{code} diff --git a/compiler/utils/Bag.lhs b/compiler/utils/Bag.lhs index 097a112..700878a 100644 --- a/compiler/utils/Bag.lhs +++ b/compiler/utils/Bag.lhs @@ -41,6 +41,7 @@ data Bag a | UnitBag a | TwoBags (Bag a) (Bag a) -- INVARIANT: neither branch is empty | ListBag [a] -- INVARIANT: the list is non-empty + deriving Typeable emptyBag :: Bag a emptyBag = EmptyBag @@ -262,8 +263,6 @@ bagToList b = foldrBag (:) [] b instance (Outputable a) => Outputable (Bag a) where ppr bag = braces (pprWithCommas ppr (bagToList bag)) -INSTANCE_TYPEABLE1(Bag,bagTc,"Bag") - instance Data a => Data (Bag a) where gfoldl k z b = z listToBag `k` bagToList b -- traverse abstract type abstractly toConstr _ = abstractConstr $ "Bag("++show (typeOf (undefined::a))++")" diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs index e178e99..c4a685b 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -60,7 +60,7 @@ module Outputable ( -- * Error handling and debugging utilities pprPanic, pprSorry, assertPprPanic, pprPanicFastInt, pprPgmError, - pprTrace, warnPprTrace, + pprTrace, pprDefiniteTrace, warnPprTrace, trace, pgmError, panic, sorry, panicFastInt, assertPanic ) where @@ -800,6 +800,9 @@ pprTrace str doc x | opt_NoDebugOutput = x | otherwise = pprAndThen trace str doc x +pprDefiniteTrace :: String -> SDoc -> a -> a +-- ^ Same as pprTrace, but show even if -dno-debug-output is on +pprDefiniteTrace str doc x = pprAndThen trace str doc x pprPanicFastInt :: String -> SDoc -> FastInt -- ^ Specialization of pprPanic that can be safely used with 'FastInt' diff --git a/compiler/utils/Util.lhs b/compiler/utils/Util.lhs index 0e46889..dc4f32e 100644 --- a/compiler/utils/Util.lhs +++ b/compiler/utils/Util.lhs @@ -66,6 +66,9 @@ module Util ( -- * Floating point readRational, + -- * read helpers + maybeReadFuzzy, + -- * IO-ish utilities createDirectoryHierarchy, doesDirNameExist, @@ -966,6 +969,17 @@ readRational top_s ----------------------------------------------------------------------------- +-- read helpers + +maybeReadFuzzy :: Read a => String -> Maybe a +maybeReadFuzzy str = case reads str of + [(x, s)] + | all isSpace s -> + Just x + _ -> + Nothing + +----------------------------------------------------------------------------- -- Create a hierarchy of directories createDirectoryHierarchy :: FilePath -> IO () diff --git a/configure.ac b/configure.ac index 7baa3dd..9278126 100644 --- a/configure.ac +++ b/configure.ac @@ -132,10 +132,12 @@ if test "$WithGhc" != ""; then GhcCanonVersion="$GhcMajVersion$GhcMinVersion2" if test $GhcCanonVersion -ge 613; then ghc_ge_613=YES; else ghc_ge_613=NO; fi AC_SUBST(ghc_ge_613)dnl + + BOOTSTRAPPING_GHC_INFO_FIELD([CC_STAGE0],[C compiler command],['$(CC)']) fi dnl ** Must have GHC to build GHC, unless --enable-hc-boot is on -if test "$BootingFromHc" = "NO" -a -d "$srcdir/compiler"; then +if test "$BootingFromHc" = "NO"; then if test "$WithGhc" = ""; then AC_MSG_ERROR([GHC is required unless bootstrapping from .hc files.]) fi @@ -537,7 +539,7 @@ dnl ** look for GCC and find out which version dnl Figure out which C compiler to use. Gcc is preferred. dnl If gcc, make sure it's at least 2.1 dnl -FP_HAVE_GCC +FP_GCC_VERSION FPTOOLS_SET_C_LD_FLAGS([target],[CFLAGS],[LDFLAGS],[IGNORE_LINKER_LD_FLAGS],[CPPFLAGS]) FPTOOLS_SET_C_LD_FLAGS([build],[CONF_CC_OPTS_STAGE0],[CONF_GCC_LINKER_OPTS_STAGE0],[CONF_LD_LINKER_OPTS_STAGE0],[CONF_CPP_OPTS_STAGE0]) @@ -578,7 +580,6 @@ AC_DEFINE([HAVE_BIN_SH], [1], [Define to 1 if you have /bin/sh.]) dnl ** how to invoke `ar' and `ranlib' FP_PROG_AR_SUPPORTS_ATFILE FP_PROG_AR_NEEDS_RANLIB -FP_PROG_AR_SUPPORTS_INPUT dnl ** Check to see whether ln -s works AC_PROG_LN_S @@ -931,7 +932,7 @@ if grep ' ' compiler/ghc.cabal.in 2>&1 >/dev/null; then AC_MSG_ERROR([compiler/ghc.cabal.in contains tab characters; please remove them]) fi -AC_CONFIG_FILES([mk/config.mk mk/install.mk mk/project.mk compiler/ghc.cabal ghc/ghc-bin.cabal utils/runghc/runghc.cabal ghc.spec extra-gcc-opts docs/users_guide/ug-book.xml docs/users_guide/ug-ent.xml docs/index.html libraries/prologue.txt distrib/ghc.iss distrib/configure.ac]) +AC_CONFIG_FILES([mk/config.mk mk/install.mk mk/project.mk compiler/ghc.cabal ghc/ghc-bin.cabal utils/runghc/runghc.cabal ghc.spec settings docs/users_guide/ug-book.xml docs/users_guide/ug-ent.xml docs/index.html libraries/prologue.txt distrib/ghc.iss distrib/configure.ac]) AC_CONFIG_COMMANDS([mk/stamp-h],[echo timestamp > mk/stamp-h]) AC_OUTPUT diff --git a/distrib/Makefile b/distrib/Makefile index f1d63bc..7f8add1 100644 --- a/distrib/Makefile +++ b/distrib/Makefile @@ -34,7 +34,7 @@ install:: $(MAKE) -C gmp install DOING_BIN_DIST=YES $(MAKE) -C docs install-docs DOING_BIN_DIST=YES $(MAKE) -C libraries/Cabal/doc install-docs DOING_BIN_DIST=YES - $(INSTALL_DATA) $(INSTALL_OPTS) extra-gcc-opts $(libdir) + $(INSTALL_DATA) $(INSTALL_OPTS) settings $(libdir) install :: postinstall denounce diff --git a/distrib/configure.ac.in b/distrib/configure.ac.in index d5aa2be..7df0f3b 100644 --- a/distrib/configure.ac.in +++ b/distrib/configure.ac.in @@ -55,7 +55,7 @@ export CC WhatGccIsCalled="$CC" AC_SUBST(WhatGccIsCalled) -FP_HAVE_GCC +FP_GCC_VERSION AC_PROG_CPP # @@ -88,7 +88,7 @@ dnl ** how to invoke `ar' and `ranlib' FP_PROG_AR_NEEDS_RANLIB # -AC_CONFIG_FILES(extra-gcc-opts mk/config.mk mk/install.mk) +AC_CONFIG_FILES(settings mk/config.mk mk/install.mk) AC_OUTPUT # We get caught by diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml index 8829c60..73faae7 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/shared_libs.xml b/docs/users_guide/shared_libs.xml index def773c..89b656a 100644 --- a/docs/users_guide/shared_libs.xml +++ b/docs/users_guide/shared_libs.xml @@ -16,7 +16,7 @@ shared between several programs. In contrast, with static linking the code is copied into each program. Using shared libraries can thus save disk space. They also allow a single copy of code to be shared in memory - between several programs that use it. Shared libraires are often used as + between several programs that use it. Shared libraries are often used as a way of structuring large projects, especially where different parts are written in different programming languages. Shared libraries are also commonly used as a plugin mechanism by various applications. This is 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/extra-gcc-opts.in b/extra-gcc-opts.in deleted file mode 100644 index 8c9832c..0000000 --- a/extra-gcc-opts.in +++ /dev/null @@ -1 +0,0 @@ -@GccExtraViaCOpts@ diff --git a/ghc.mk b/ghc.mk index 863ddc2..b00d925 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 @@ -749,7 +750,7 @@ TAGS: TAGS_compiler # ----------------------------------------------------------------------------- # Installation -install: install_packages install_libs install_libexecs install_headers \ +install: install_libs install_packages install_libexecs install_headers \ install_libexec_scripts install_bins install_topdirs ifeq "$(HADDOCK_DOCS)" "YES" install: install_docs @@ -903,7 +904,7 @@ $(eval $(call bindist,.,\ README \ INSTALL \ configure config.sub config.guess install-sh \ - extra-gcc-opts.in \ + settings.in \ packages \ Makefile \ mk/config.mk.in \ @@ -932,7 +933,7 @@ $(eval $(call bindist,.,\ compiler/stage2/doc \ $(wildcard libraries/*/dist-install/doc/) \ $(wildcard libraries/*/*/dist-install/doc/) \ - $(filter-out extra-gcc-opts,$(INSTALL_LIBS)) \ + $(filter-out settings,$(INSTALL_LIBS)) \ $(filter-out %/project.mk mk/config.mk %/mk/install.mk,$(MAKEFILE_LIST)) \ mk/project.mk \ mk/install.mk.in \ @@ -953,7 +954,7 @@ BIN_DIST_MK = $(BIN_DIST_PREP_DIR)/bindist.mk unix-binary-dist-prep: "$(RM)" $(RM_OPTS_REC) bindistprep/ "$(MKDIRHIER)" $(BIN_DIST_PREP_DIR) - set -e; for i in packages LICENSE compiler ghc rts libraries utils docs libffi includes driver mk rules Makefile aclocal.m4 config.sub config.guess install-sh extra-gcc-opts.in ghc.mk inplace distrib/configure.ac distrib/README distrib/INSTALL; do ln -s ../../$$i $(BIN_DIST_PREP_DIR)/; done + set -e; for i in packages LICENSE compiler ghc rts libraries utils docs libffi includes driver mk rules Makefile aclocal.m4 config.sub config.guess install-sh settings.in ghc.mk inplace distrib/configure.ac distrib/README distrib/INSTALL; do ln -s ../../$$i $(BIN_DIST_PREP_DIR)/; done echo "HADDOCK_DOCS = $(HADDOCK_DOCS)" >> $(BIN_DIST_MK) echo "LATEX_DOCS = $(LATEX_DOCS)" >> $(BIN_DIST_MK) echo "BUILD_DOCBOOK_HTML = $(BUILD_DOCBOOK_HTML)" >> $(BIN_DIST_MK) @@ -1042,7 +1043,7 @@ SRC_DIST_DIRS = mk rules docs distrib bindisttest libffi includes utils docs rts SRC_DIST_FILES += \ configure.ac config.guess config.sub configure \ aclocal.m4 README ANNOUNCE HACKING LICENSE Makefile install-sh \ - ghc.spec.in ghc.spec extra-gcc-opts.in VERSION \ + ghc.spec.in ghc.spec settings.in VERSION \ boot boot-pkgs packages ghc.mk SRC_DIST_TARBALL = $(SRC_DIST_NAME)-src.tar.bz2 @@ -1157,7 +1158,7 @@ distclean : clean "$(RM)" $(RM_OPTS) config.cache config.status config.log mk/config.h mk/stamp-h "$(RM)" $(RM_OPTS) mk/config.mk mk/are-validating.mk mk/project.mk "$(RM)" $(RM_OPTS) mk/config.mk.old mk/project.mk.old - "$(RM)" $(RM_OPTS) extra-gcc-opts docs/users_guide/ug-book.xml + "$(RM)" $(RM_OPTS) settings docs/users_guide/ug-book.xml "$(RM)" $(RM_OPTS) compiler/ghc.cabal compiler/ghc.cabal.old "$(RM)" $(RM_OPTS) ghc/ghc-bin.cabal "$(RM)" $(RM_OPTS) libraries/base/include/HsBaseConfig.h diff --git a/ghc/Main.hs b/ghc/Main.hs index 9c99334..12d8dd2 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -78,7 +78,8 @@ import Data.Maybe main :: IO () main = do hSetBuffering stdout NoBuffering - GHC.defaultErrorHandler defaultDynFlags $ do + let defaultErrorHandlerDynFlags = defaultDynFlags (panic "No settings") + GHC.defaultErrorHandler defaultErrorHandlerDynFlags $ do -- 1. extract the -B flag from the args argv0 <- getArgs @@ -358,9 +359,6 @@ showVersionMode = mkPreStartupMode ShowVersion showNumVersionMode = mkPreStartupMode ShowNumVersion showSupportedExtensionsMode = mkPreStartupMode ShowSupportedExtensions -printMode :: String -> Mode -printMode str = mkPreStartupMode (Print str) - mkPreStartupMode :: PreStartupMode -> Mode mkPreStartupMode = Left @@ -383,8 +381,10 @@ showGhcUsageMode = mkPreLoadMode ShowGhcUsage showGhciUsageMode = mkPreLoadMode ShowGhciUsage showInfoMode = mkPreLoadMode ShowInfo -printWithDynFlagsMode :: (DynFlags -> String) -> Mode -printWithDynFlagsMode f = mkPreLoadMode (PrintWithDynFlags f) +printSetting :: String -> Mode +printSetting k = mkPreLoadMode (PrintWithDynFlags f) + where f dflags = fromMaybe (panic ("Setting not found: " ++ show k)) + $ lookup k (compilerInfo dflags) mkPreLoadMode :: PreLoadMode -> Mode mkPreLoadMode = Right . Left @@ -504,14 +504,30 @@ mode_flags = , Flag "-supported-languages" (PassFlag (setMode showSupportedExtensionsMode)) , Flag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode)) ] ++ - [ Flag k' (PassFlag (setMode mode)) - | (k, v) <- compilerInfo, + [ Flag k' (PassFlag (setMode (printSetting k))) + | k <- ["Project version", + "Booter version", + "Stage", + "Build platform", + "Host platform", + "Target platform", + "Have interpreter", + "Object splitting supported", + "Have native code generator", + "Support SMP", + "Unregisterised", + "Tables next to code", + "RTS ways", + "Leading underscore", + "Debug on", + "LibDir", + "Global Package DB", + "C compiler flags", + "Gcc Linker flags", + "Ld Linker flags"], let k' = "-print-" ++ map (replaceSpace . toLower) k replaceSpace ' ' = '-' replaceSpace c = c - mode = case v of - String str -> printMode str - FromDynFlags f -> printWithDynFlagsMode f ] ++ ------- interfaces ---------------------------------------------------- [ Flag "-show-iface" (HasArg (\f -> setMode (showInterfaceMode f) @@ -649,9 +665,7 @@ showBanner _postLoadMode dflags = do showInfo :: DynFlags -> IO () showInfo dflags = do let sq x = " [" ++ x ++ "\n ]" - putStrLn $ sq $ concat $ intersperse "\n ," $ map (show . flatten) compilerInfo - where flatten (k, String v) = (k, v) - flatten (k, FromDynFlags f) = (k, f dflags) + putStrLn $ sq $ intercalate "\n ," $ map show $ compilerInfo dflags showSupportedExtensions :: IO () showSupportedExtensions = mapM_ putStrLn supportedLanguagesAndExtensions diff --git a/ghc/ghc-bin.cabal.in b/ghc/ghc-bin.cabal.in index 420c918..61b7b34 100644 --- a/ghc/ghc-bin.cabal.in +++ b/ghc/ghc-bin.cabal.in @@ -14,7 +14,7 @@ Description: XXX Category: XXX Data-Dir: .. -Data-Files: extra-gcc-opts +Data-Files: settings Build-Type: Simple Cabal-Version: >= 1.2 diff --git a/ghc/ghc.mk b/ghc/ghc.mk index 8776566..da9fd8a 100644 --- a/ghc/ghc.mk +++ b/ghc/ghc.mk @@ -108,24 +108,26 @@ all_ghc_stage1 : $(GHC_STAGE1) all_ghc_stage2 : $(GHC_STAGE2) all_ghc_stage3 : $(GHC_STAGE3) -$(INPLACE_LIB)/extra-gcc-opts : extra-gcc-opts +$(INPLACE_LIB)/settings : settings "$(CP)" $< $@ -# The GHC programs need to depend on all the helper programs they might call +# The GHC programs need to depend on all the helper programs they might call, +# and the settings files they use + +$(GHC_STAGE1) : | $(UNLIT) $(INPLACE_LIB)/settings +$(GHC_STAGE2) : | $(UNLIT) $(INPLACE_LIB)/settings +$(GHC_STAGE3) : | $(UNLIT) $(INPLACE_LIB)/settings + ifeq "$(GhcUnregisterised)" "NO" -$(GHC_STAGE1) : $(SPLIT) -$(GHC_STAGE2) : $(SPLIT) -$(GHC_STAGE3) : $(SPLIT) +$(GHC_STAGE1) : | $(SPLIT) +$(GHC_STAGE2) : | $(SPLIT) +$(GHC_STAGE3) : | $(SPLIT) endif -$(GHC_STAGE1) : $(INPLACE_LIB)/extra-gcc-opts -$(GHC_STAGE2) : $(INPLACE_LIB)/extra-gcc-opts -$(GHC_STAGE3) : $(INPLACE_LIB)/extra-gcc-opts - ifeq "$(Windows)" "YES" -$(GHC_STAGE1) : $(TOUCHY) -$(GHC_STAGE2) : $(TOUCHY) -$(GHC_STAGE3) : $(TOUCHY) +$(GHC_STAGE1) : | $(TOUCHY) +$(GHC_STAGE2) : | $(TOUCHY) +$(GHC_STAGE3) : | $(TOUCHY) endif ifeq "$(BootingFromHc)" "YES" @@ -135,7 +137,7 @@ endif endif -INSTALL_LIBS += extra-gcc-opts +INSTALL_LIBS += settings ifeq "$(Windows)" "NO" install: install_ghc_link diff --git a/libffi/ghc.mk b/libffi/ghc.mk index 080c43f..f7caeda 100644 --- a/libffi/ghc.mk +++ b/libffi/ghc.mk @@ -34,8 +34,6 @@ # # We use libffi's own configuration stuff. -PLATFORM := $(shell echo $(HOSTPLATFORM) | sed 's/i[567]86/i486/g') - # 2007-07-05 # Passing # as_ln_s='cp -p' @@ -116,16 +114,16 @@ $(libffi_STAMP_CONFIGURE): PATH=`pwd`:$$PATH; \ export PATH; \ cd build && \ - CC=$(WhatGccIsCalled) \ + CC=$(CC_STAGE1) \ LD=$(LD) \ - AR=$(AR) \ + AR=$(AR_STAGE1) \ NM=$(NM) \ CFLAGS="$(SRC_CC_OPTS) $(CONF_CC_OPTS_STAGE1) -w" \ LDFLAGS="$(SRC_LD_OPTS) $(CONF_GCC_LINKER_OPTS_STAGE1) -w" \ "$(SHELL)" configure \ --enable-static=yes \ --enable-shared=$(libffi_EnableShared) \ - --host=$(PLATFORM) --build=$(PLATFORM) + --host=$(HOSTPLATFORM) --build=$(BUILDPLATFORM) # libffi.so needs to be built with the correct soname. # NOTE: this builds libffi_convience.so with the incorrect @@ -179,7 +177,7 @@ $(eval $(call all-target,libffi,$(INSTALL_HEADERS) $(INSTALL_LIBS))) libffi/dist-install/build/HSffi.o: libffi/dist-install/build/libHSffi.a cd libffi/dist-install/build && \ touch empty.c && \ - "$(CC)" $(SRC_CC_OPTS) $(CONF_CC_OPTS_STAGE1) -c empty.c -o HSffi.o + "$(CC_STAGE1)" $(SRC_CC_OPTS) $(CONF_CC_OPTS_STAGE1) -c empty.c -o HSffi.o $(eval $(call all-target,libffi,libffi/dist-install/build/HSffi.o)) @@ -227,4 +225,3 @@ $(eval $(call manual-package-config,libffi)) # binary-dist BINDIST_EXTRAS += libffi/package.conf.in - diff --git a/libraries/Makefile.common b/libraries/Makefile.common deleted file mode 100644 index 8fe1462..0000000 --- a/libraries/Makefile.common +++ /dev/null @@ -1,118 +0,0 @@ -# This Makefile.common is used only in an nhc98 build of the libraries. -# It is included from each package's individual Makefile.nhc98. -# We assume the following definitions have already been made in -# the importing Makefile. -# -# THISPKG = e.g. mypkg -# SEARCH = e.g. -P../IO -P../PreludeIO -package base -# SRCS = all .hs .gc and .c files -# -# EXTRA_H_FLAGS = e.g. -prelude -# EXTRA_C_FLAGS = e.g. -I../Binary -include ../Makefile.inc - -# nasty hack - replace flags for ghc, nhc98, with hbc specific ones -ifeq "hbc" "${BUILDCOMP}" -EXTRA_H_FLAGS := ${EXTRA_HBC_FLAGS} -endif - -DIRS = $(shell ${LOCAL}pkgdirlist ${THISPKG}) - -OBJDIR = ${BUILDDIR}/${OBJ}/libraries/${THISPKG} -OBJDIRS = $(patsubst %, ${OBJDIR}/%, ${DIRS}) -FINALLIB = ${DST}/libHS${THISPKG}.$A -INCDIRS = ${INCDIR}/packages/${THISPKG} \ - $(patsubst %, ${INCDIR}/packages/${THISPKG}/%, ${DIRS}) -.SUFFIXES: .hi .hs .lhs .o .gc .c .hc .p.o .p.c .z.o .z.c .hsc - -SRCS_HS = $(filter %.hs, ${SRCS}) -SRCS_LHS = $(filter %.lhs,${SRCS}) -SRCS_GC = $(filter %.gc, ${SRCS}) -SRCS_HSC = $(filter %.hsc,${SRCS}) -SRCS_C = $(filter %.c, ${SRCS}) -SRCS_HASK= $(SRCS_HS) $(SRCS_LHS) $(SRCS_GC) $(SRCS_HSC) - -OBJS_HS = $(patsubst %.hs, ${OBJDIR}/%.$O, ${SRCS_HS}) -OBJS_LHS = $(patsubst %.lhs,${OBJDIR}/%.$O, ${SRCS_LHS}) -OBJS_GC = $(patsubst %.gc, ${OBJDIR}/%.$O, ${SRCS_GC}) -OBJS_HSC = $(patsubst %.hsc,${OBJDIR}/%.$O, ${SRCS_HSC}) -OBJS_C = $(patsubst %.c, ${OBJDIR}/%.$O, ${SRCS_C}) -OBJS_HASK= ${OBJS_HS} ${OBJS_LHS} ${OBJS_GC} ${OBJS_HSC} -OBJS = $(OBJS_HASK) $(OBJS_C) - -CFILES_HS = $(patsubst %.hs, %.$C, ${SRCS_HS}) -CFILES_LHS = $(patsubst %.lhs,%.$C, ${SRCS_LHS}) -CFILES_GC = $(patsubst %.gc, %.$C, ${SRCS_GC}) -CFILES_XS = $(patsubst %.gc, %_.$C, ${SRCS_GC}) \ - $(patsubst %.gc, %_.hs, ${SRCS_GC}) -CFILES_HSC = $(patsubst %.hsc,%.$C, ${SRCS_HSC}) -CFILES_GEN = ${CFILES_HS} ${CFILES_LHS} ${CFILES_GC} ${CFILES_HSC} - -ifeq "p" "${PROFILING}" -HC += -p -endif - -ifeq "z" "${TPROF}" -HC += -z -endif - -all: ${OBJDIR} ${OBJDIRS} ${INCDIRS} extra ${OBJS} ${FINALLIB} -extra: -cfiles: extracfiles ${CFILES_GEN} -extracfiles: -fromC: ${OBJDIR} ${OBJS_C} ${OBJDIRS} - $(HC) -c -d $(OBJDIR) $(EXTRA_C_FLAGS) ${SEARCH} ${CFILES_GEN} - echo $(OBJS) | xargs ar cr ${FINALLIB} -objdir: ${OBJDIR} ${OBJDIRS} ${INCDIRS} -${OBJDIR} ${OBJDIRS} ${INCDIRS}: - mkdir -p $@ -${FINALLIB}: ${OBJS} - echo $(OBJS) | xargs ar cr $@ -cleanhi: - -rm -f $(patsubst %, %/*.hi, ${DIRS}) -cleanC: cleanExtraC - -rm -f ${CFILES_GEN} ${CFILES_XS} -clean: cleanhi - -rm -f $(patsubst %, ${OBJDIR}/%/*.$O, ${DIRS}) - -rm -f $(patsubst %.gc, %_.hs, $(filter %.gc, $(SRCS))) - -rm -f $(patsubst %.gc, %_.$C, $(filter %.gc, $(SRCS))) -cleanExtraC: - -# general build rules for making objects from Haskell files -$(OBJS_HASK): #$(OBJDIR) $(OBJDIRS) $(SRCS_HASK) - $(LOCAL)hmake -hc=$(HC) -hidir $(INCDIR)/packages/$(THISPKG) \ - $(SEARCH) $(EXTRA_H_FLAGS) -d$(OBJDIR) \ - $(SRCS_HASK) -${OBJS_HS}: ${OBJDIR}/%.$O : %.hs -${OBJS_LHS}: ${OBJDIR}/%.$O : %.lhs -${OBJS_GC}: ${OBJDIR}/%.$O : %.gc -${OBJS_HSC}: ${OBJDIR}/%.$O : %.hsc - -# general build rule for making objects from C files -${OBJS_C}: ${OBJDIR}/%.$O : cbits/%.c - $(CC) -c -I$(INCDIR) $(ENDIAN) $(filter -I%, ${SEARCH}) \ - $(EXTRA_C_FLAGS) -o $@ $< - -# general build rules for making bootstrap C files from Haskell files -$(CFILES_GEN): - $(LOCAL)hmake -hc=$(HC) -C -hidir $(INCDIR)/packages/$(THISPKG) \ - $(SEARCH) $(EXTRA_H_FLAGS) \ - $(SRCS_HASK) -${CFILES_HS}: %.$C : %.hs -${CFILES_LHS}: %.$C : %.lhs -${CFILES_GC}: %.$C : %.gc -${CFILES_HSC}: %.$C : %.hsc - -# hack to get round mutual recursion between libraries -HIFILES = $(patsubst %.hs,../${THISLIB}/%.${HISUFFIX},$(filter %.hs, ${SRCS})) -${HIFILES}: ../${THISLIB}/%.${HISUFFIX} : %.hs - $(HC) -c $(PART_FLAGS) -o /dev/null $< - -# The importing Makefile may now define extra individual dependencies -# e.g. -# ${OBJDIR}/Function.$O: Function.hs ${OBJDIR}/Other.$O -# -# and C-files dependencies likewise -# e.g. -# AlignBin.c: BinHandle.c - diff --git a/libraries/Makefile.inc b/libraries/Makefile.inc deleted file mode 100644 index 0b54f52..0000000 --- a/libraries/Makefile.inc +++ /dev/null @@ -1,8 +0,0 @@ -ifeq "" "${MKDIR}" -MKDIR:=$(shell pwd) -#MKDIR:=$(PWD) -else -MKDIR:=$(patsubst %/$(notdir ${MKDIR}),%, ${MKDIR}) -endif -include ${MKDIR}/Makefile.inc - diff --git a/libraries/Makefile.local b/libraries/Makefile.local deleted file mode 100644 index 84b90a6..0000000 --- a/libraries/Makefile.local +++ /dev/null @@ -1,38 +0,0 @@ -# Local GHC-build-tree customization for Cabal makefiles. We want to build -# libraries using flags that the user has put in build.mk/validate.mk and -# appropriate flags for Mac OS X deployment targets. - -# Careful here: including boilerplate.mk breaks things, because paths.mk and -# opts.mk overrides some of the variable settings in the Cabal Makefile, so -# we just include config.mk and custom-settings.mk. -include ../defineTOP.mk -SAVE_GHC := $(GHC) -SAVE_AR := $(AR) -SAVE_LD := $(LD) -include $(TOP)/mk/config.mk -include $(TOP)/mk/custom-settings.mk -GHC := $(SAVE_GHC) -AR := $(SAVE_AR) -LD := $(SAVE_LD) - -# We want all warnings on -GhcLibHcOpts += -Wall - -# Cabal has problems with deprecated flag warnings, as it needs to pass -# deprecated flags in pragmas in order to support older GHCs. Thus for -# now at least we just disable them completely. -GhcLibHcOpts += -fno-warn-deprecated-flags - -ifeq "$(filter-out Win32-% dph%,$(package))" "" -# XXX We are one of the above list, i.e. we are a package that is not -# yet warning-clean. Thus turn warnings off for now so that validate -# goes through. -GhcLibHcOpts += -w -endif - -# Now add flags from the GHC build system to the Cabal build: -GHC_OPTS += $(SRC_HC_OPTS) -GHC_OPTS += $(GhcLibHcOpts) - -include $(TOP)/mk/bindist.mk - diff --git a/libraries/tarballs/time-1.2.0.3.tar.gz b/libraries/tarballs/time-1.2.0.3.tar.gz deleted file mode 100644 index 525b019..0000000 Binary files a/libraries/tarballs/time-1.2.0.3.tar.gz and /dev/null differ diff --git a/libraries/tarballs/time-1.2.0.4.tar.gz b/libraries/tarballs/time-1.2.0.4.tar.gz new file mode 100644 index 0000000..6bbbd75 Binary files /dev/null and b/libraries/tarballs/time-1.2.0.4.tar.gz differ diff --git a/mk/config.mk.in b/mk/config.mk.in index be8b57b..f96302b 100644 --- a/mk/config.mk.in +++ b/mk/config.mk.in @@ -540,18 +540,14 @@ endif # the flag --with-gcc= instead. The reason is that the configure script # needs to know which gcc you're using in order to perform its tests. -HaveGcc = @HaveGcc@ -UseGcc = YES WhatGccIsCalled = @WhatGccIsCalled@ GccVersion = @GccVersion@ -GccLT34 = @GccLT34@ -ifeq "$(strip $(HaveGcc))" "YES" -ifneq "$(strip $(UseGcc))" "YES" - CC = cc -else - CC = $(WhatGccIsCalled) -endif -endif +GccLT34 = @GccLT34@ +CC = $(WhatGccIsCalled) +CC_STAGE0 = @CC_STAGE0@ +CC_STAGE1 = $(CC) +CC_STAGE2 = $(CC) +CC_STAGE3 = $(CC) # C compiler and linker flags from configure (e.g. -m to select # correct C compiler backend). The stage number is the stage of GHC @@ -601,10 +597,24 @@ DLLTOOL = inplace/mingw/bin/dlltool.exe AR = @ArCmd@ AR_OPTS = @ArArgs@ -ArSupportsInput = @ArSupportsInput@ ArSupportsAtFile = @ArSupportsAtFile@ -# Yuckage: for ghc/utils/parallel -- todo: nuke this dependency!! -BASH = /usr/local/bin/bash + +AR_STAGE0 = $(AR) +AR_STAGE1 = $(AR) +AR_STAGE2 = $(AR) +AR_STAGE3 = $(AR) +AR_OPTS_STAGE0 = $(AR_OPTS) +AR_OPTS_STAGE1 = $(AR_OPTS) +AR_OPTS_STAGE2 = $(AR_OPTS) +AR_OPTS_STAGE3 = $(AR_OPTS) +EXTRA_AR_ARGS_STAGE0 = $(EXTRA_AR_ARGS) +EXTRA_AR_ARGS_STAGE1 = $(EXTRA_AR_ARGS) +EXTRA_AR_ARGS_STAGE2 = $(EXTRA_AR_ARGS) +EXTRA_AR_ARGS_STAGE3 = $(EXTRA_AR_ARGS) +ArSupportsAtFile_STAGE0 = $(ArSupportsAtFile) +ArSupportsAtFile_STAGE1 = $(ArSupportsAtFile) +ArSupportsAtFile_STAGE2 = $(ArSupportsAtFile) +ArSupportsAtFile_STAGE3 = $(ArSupportsAtFile) CONTEXT_DIFF = @ContextDiffCmd@ CP = cp @@ -637,7 +647,6 @@ NROFF = nroff PERL = @PerlCmd@ PYTHON = @PythonCmd@ PIC = pic -PREPROCESSCMD = $(CC) -E RANLIB = @RANLIB@ SED = @SedCmd@ TR = tr 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 c840857..c1310b0 100644 --- a/rts/Linker.c +++ b/rts/Linker.c @@ -1186,11 +1186,11 @@ initLinker( void ) # endif /* RTLD_DEFAULT */ compileResult = regcomp(&re_invalid, - "(([^ \t()])+\\.so([^ \t:()])*):([ \t])*invalid ELF header", + "(([^ \t()])+\\.so([^ \t:()])*):([ \t])*(invalid ELF header|file too short)", REG_EXTENDED); ASSERT( compileResult == 0 ); compileResult = regcomp(&re_realso, - "GROUP *\\( *(([^ )])+)", + "(GROUP|INPUT) *\\( *(([^ )])+)", REG_EXTENDED); ASSERT( compileResult == 0 ); # endif @@ -1361,8 +1361,8 @@ addDLL( char *dll_name ) if (regexec(&re_realso, line, (size_t) NMATCH, match, 0) == 0) { // success -- try to dlopen the first named file IF_DEBUG(linker, debugBelch("match%s\n","")); - line[match[1].rm_eo] = '\0'; - errmsg = internal_dlopen(line+match[1].rm_so); + line[match[2].rm_eo] = '\0'; + errmsg = internal_dlopen(line+match[2].rm_so); break; } // if control reaches here, no GROUP ( ... ) directive was found 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..a236945 100644 --- a/rts/ghc.mk +++ b/rts/ghc.mk @@ -194,8 +194,8 @@ endif else $$(rts_$1_LIB) : $$(rts_$1_OBJS) $$(rts_$1_DTRACE_OBJS) "$$(RM)" $$(RM_OPTS) $$@ - echo $$(rts_$1_OBJS) $$(rts_$1_DTRACE_OBJS) | "$$(XARGS)" $$(XARGS_OPTS) "$$(AR)" \ - $$(AR_OPTS) $$(EXTRA_AR_ARGS) $$@ + echo $$(rts_$1_OBJS) $$(rts_$1_DTRACE_OBJS) | "$$(XARGS)" $$(XARGS_OPTS) "$$(AR_STAGE1)" \ + $$(AR_OPTS_STAGE1) $$(EXTRA_AR_ARGS_STAGE1) $$@ endif endif @@ -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) @@ -500,7 +499,7 @@ endif ifneq "$(BINDIST)" "YES" rts/dist/build/libHSrtsmain.a : rts/dist/build/Main.o "$(RM)" $(RM_OPTS) $@ - "$(AR)" $(AR_OPTS) $(EXTRA_AR_ARGS) $@ $< + "$(AR_STAGE1)" $(AR_OPTS_STAGE1) $(EXTRA_AR_ARGS_STAGE1) $@ $< endif # ----------------------------------------------------------------------------- diff --git a/rts/sm/GC.c b/rts/sm/GC.c index 05bc8f2..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", 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-way.mk b/rules/build-package-way.mk index d6c1560..a7dc918 100644 --- a/rules/build-package-way.mk +++ b/rules/build-package-way.mk @@ -87,10 +87,10 @@ ifeq "$$($1_$2_SplitObjs)" "YES" else echo $$($1_$2_$3_ALL_OBJS) >> $$@.contents endif -ifeq "$$(ArSupportsAtFile)" "YES" - "$$(AR)" $$(AR_OPTS) $$(EXTRA_AR_ARGS) $$@ @$$@.contents +ifeq "$$($1_$2_ArSupportsAtFile)" "YES" + "$$($1_$2_AR)" $$($1_$2_AR_OPTS) $$($1_$2_EXTRA_AR_ARGS) $$@ @$$@.contents else - "$$(XARGS)" $$(XARGS_OPTS) "$$(AR)" $$(AR_OPTS) $$(EXTRA_AR_ARGS) $$@ < $$@.contents + "$$(XARGS)" $$(XARGS_OPTS) "$$($1_$2_AR)" $$($1_$2_AR_OPTS) $$($1_$2_EXTRA_AR_ARGS) $$@ < $$@.contents endif "$$(RM)" $$(RM_OPTS) $$@.contents endif 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..99093d3 100644 --- a/rules/build-prog.mk +++ b/rules/build-prog.mk @@ -156,7 +156,7 @@ $1/$2/build/tmp/$$($1_$2_PROG) : $$($1_$2_v_HS_OBJS) $$($1_$2_v_C_OBJS) $$($1_$2 "$$($1_$2_HC)" -o $$@ $$($1_$2_v_ALL_HC_OPTS) $$(LD_OPTS) $$($1_$2_GHC_LD_OPTS) $$($1_$2_v_HS_OBJS) $$($1_$2_v_C_OBJS) $$($1_$2_v_S_OBJS) $$($1_$2_OTHER_OBJS) $$(addprefix -l,$$($1_$2_EXTRA_LIBRARIES)) else $1/$2/build/tmp/$$($1_$2_PROG) : $$($1_$2_v_HS_OBJS) $$($1_$2_v_C_OBJS) $$($1_$2_v_S_OBJS) $$($1_$2_OTHER_OBJS) | $$$$(dir $$$$@)/. - "$$(CC)" -o $$@ $$($1_$2_v_ALL_CC_OPTS) $$(LD_OPTS) $$($1_$2_v_HS_OBJS) $$($1_$2_v_C_OBJS) $$($1_$2_v_S_OBJS) $$($1_$2_OTHER_OBJS) $$($1_$2_v_EXTRA_CC_OPTS) $$(addprefix -l,$$($1_$2_EXTRA_LIBRARIES)) + "$$($1_$2_CC)" -o $$@ $$($1_$2_v_ALL_CC_OPTS) $$(LD_OPTS) $$($1_$2_v_HS_OBJS) $$($1_$2_v_C_OBJS) $$($1_$2_v_S_OBJS) $$($1_$2_OTHER_OBJS) $$($1_$2_v_EXTRA_CC_OPTS) $$(addprefix -l,$$($1_$2_EXTRA_LIBRARIES)) endif # Note [lib-depends] if this program is built with stage1 or greater, we @@ -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/c-suffix-rules.mk b/rules/c-suffix-rules.mk index fa7dd6f..bba73a8 100644 --- a/rules/c-suffix-rules.mk +++ b/rules/c-suffix-rules.mk @@ -43,19 +43,19 @@ $1/$2/build/%.$$($3_way_)s : $1/%.c $$($1_$2_HC_DEP) else $1/$2/build/%.$$($3_osuf) : $1/%.c | $$$$(dir $$$$@)/. - "$$(CC)" $$($1_$2_$3_ALL_CC_OPTS) -c $$< -o $$@ + "$$($1_$2_CC)" $$($1_$2_$3_ALL_CC_OPTS) -c $$< -o $$@ $1/$2/build/%.$$($3_osuf) : $1/$2/build/%.c - "$$(CC)" $$($1_$2_$3_ALL_CC_OPTS) -c $$< -o $$@ + "$$($1_$2_CC)" $$($1_$2_$3_ALL_CC_OPTS) -c $$< -o $$@ $1/$2/build/%.$$($3_osuf) : $1/$2/build/%.$$($3_way_)s "$$(AS)" $$($1_$2_$3_ALL_AS_OPTS) -o $$@ $$< $1/$2/build/%.$$($3_osuf) : $1/%.S | $$$$(dir $$$$@)/. - "$$(CC)" $$($1_$2_$3_ALL_CC_OPTS) -c $$< -o $$@ + "$$($1_$2_CC)" $$($1_$2_$3_ALL_CC_OPTS) -c $$< -o $$@ $1/$2/build/%.$$($3_way_)s : $1/$2/build/%.c - "$$(CC)" $$($1_$2_$3_ALL_CC_OPTS) -S $$< -o $$@ + "$$($1_$2_CC)" $$($1_$2_$3_ALL_CC_OPTS) -S $$< -o $$@ endif 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/rules/distdir-way-opts.mk b/rules/distdir-way-opts.mk index bebbc4d..5c56169 100644 --- a/rules/distdir-way-opts.mk +++ b/rules/distdir-way-opts.mk @@ -17,9 +17,9 @@ define distdir-way-opts # args: $1 = dir, $2 = distdir, $3 = way, $4 = stage # Options for a Haskell compilation: # - CONF_HC_OPTS source-tree-wide options, selected at -# configure-time +# configure-time # - SRC_HC_OPTS source-tree-wide options from build.mk -# (optimisation, heap settings) +# (optimisation, heap settings) # - libraries/base_HC_OPTS options from Cabal for libraries/base # for all ways # - libraries/base_MORE_HC_OPTS options from elsewhere in the build @@ -27,7 +27,7 @@ define distdir-way-opts # args: $1 = dir, $2 = distdir, $3 = way, $4 = stage # - libraries/base_v_HC_OPTS options from libraries/base for way v # - WAY_v_HC_OPTS options for this way # - EXTRA_HC_OPTS options from the command-line -# - -Idir1 -Idir2 ... include-dirs from this package +# - -Idir1 -Idir2 ... include-dirs from this package # - -odir/-hidir/-stubdir put the output files under $3/build # - -osuf/-hisuf/-hcsuf suffixes for the output files in this way @@ -134,6 +134,8 @@ $1_$2_$3_ALL_HSC2HS_OPTS = \ --cflag=-D__GLASGOW_HASKELL__=$$(ProjectVersionInt) \ $$($1_$2_$3_HSC2HS_CC_OPTS) \ $$($1_$2_$3_HSC2HS_LD_OPTS) \ + --cflag=-I$1/$2/build/autogen \ + $$(if $$($1_PACKAGE),--cflag=-include --cflag=$1/$2/build/autogen/cabal_macros.h) \ $$($$(basename $$<)_HSC2HS_OPTS) \ $$(EXTRA_HSC2HS_OPTS) diff --git a/rules/hs-suffix-rules-srcdir.mk b/rules/hs-suffix-rules-srcdir.mk index 7e9c8d3..bdb9d00 100644 --- a/rules/hs-suffix-rules-srcdir.mk +++ b/rules/hs-suffix-rules-srcdir.mk @@ -52,10 +52,10 @@ endif # .hs->.o rule, I don't know why --SDM $1/$2/build/%.$$($3_osuf) : $1/$4/%.hc includes/ghcautoconf.h includes/ghcplatform.h | $$$$(dir $$$$@)/. - "$$(CC)" $$($1_$2_$3_ALL_CC_OPTS) -Iincludes -x c -c $$< -o $$@ + "$$($1_$2_CC)" $$($1_$2_$3_ALL_CC_OPTS) -Iincludes -x c -c $$< -o $$@ $1/$2/build/%.$$($3_osuf) : $1/$2/build/%.hc includes/ghcautoconf.h includes/ghcplatform.h - "$$(CC)" $$($1_$2_$3_ALL_CC_OPTS) -Iincludes -x c -c $$< -o $$@ + "$$($1_$2_CC)" $$($1_$2_$3_ALL_CC_OPTS) -Iincludes -x c -c $$< -o $$@ # $1/$2/build/%.$$($3_osuf) : $1/$2/build/%.$$($3_way_)hc # "$$($1_$2_HC)" $$($1_$2_$3_ALL_HC_OPTS) -c $$< -o $$@ diff --git a/rules/package-config.mk b/rules/package-config.mk index 2091779..7873157 100644 --- a/rules/package-config.mk +++ b/rules/package-config.mk @@ -16,6 +16,11 @@ $(call trace, package-config($1,$2,$3)) $(call profStart, package-config($1,$2,$3)) $1_$2_HC = $$(GHC_STAGE$3) +$1_$2_CC = $$(CC_STAGE$3) +$1_$2_AR = $$(AR_STAGE$3) +$1_$2_AR_OPTS = $$(AR_OPTS_STAGE$3) +$1_$2_EXTRA_AR_ARGS = $$(EXTRA_AR_ARGS_STAGE$3) +$1_$2_ArSupportsAtFile = $$(ArSupportsAtFile_STAGE$3) # configuration stuff that depends on which GHC we're building with ifeq "$3" "0" diff --git a/settings.in b/settings.in new file mode 100644 index 0000000..f4e922a --- /dev/null +++ b/settings.in @@ -0,0 +1,4 @@ +[("GCC extra via C opts", "@GccExtraViaCOpts@"), + ("C compiler command", "@WhatGccIsCalled@"), + ("perl command", "@PerlCmd@")] + diff --git a/sync-all b/sync-all index 02ac521..7ccc71d 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,162 @@ 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"; + } + else { + message "== $localpath repo not present; skipping"; } - elsif ($command =~ /^reset$/) { - @scm_args = "reset"; + } + + # 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"; } - elsif ($command =~ /^config$/) { - @scm_args = "config"; + elsif ($scm eq "git") { + $command = "status"; } else { - die "Unknown command: $command"; + die "Unknown scm"; } - - # 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); - } + + # 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 ($local_repo_unnecessary) { - # Don't bother to change directory in this case - scm (".", $scm, @scm_args, @args); - } - 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 =~ /^clean$/) { + scm ($localpath, $scm, "clean", @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"; + } } } @@ -422,6 +430,7 @@ Supported commands: * remote rm * remote set-url [--push] * grep + * clean * reset * config @@ -484,9 +493,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/utils/ghctags/Main.hs b/utils/ghctags/Main.hs index a25537e..b3ed58f 100644 --- a/utils/ghctags/Main.hs +++ b/utils/ghctags/Main.hs @@ -10,6 +10,7 @@ import DriverPhases ( isHaskellSrcFilename ) import HscTypes ( msHsFilePath ) import Name ( getOccString ) --import ErrUtils ( printBagOfErrors ) +import Panic ( panic ) import DynFlags ( defaultDynFlags ) import Bag import Exception @@ -100,7 +101,7 @@ main = do then Just `liftM` openFile "TAGS" openFileMode else return Nothing - GHC.defaultErrorHandler defaultDynFlags $ + GHC.defaultErrorHandler (defaultDynFlags (panic "No settings")) $ runGhc (Just ghc_topdir) $ do --liftIO $ print "starting up session" dflags <- getSessionDynFlags 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