From: Simon Peyton Jones Date: Thu, 28 Apr 2011 10:50:15 +0000 (+0100) Subject: Merge remote branch 'origin/master' into monad-comp X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=5ccf658872ea2304f34eda6b1fb840fc1bfc0ba0;hp=478e69b303eb2e653a2ebf5c888b5efdfef1fb9d Merge remote branch 'origin/master' into monad-comp Conflicts: compiler/main/HscMain.lhs --- diff --git a/.gitignore b/.gitignore index 32d243b..3e2e7f4 100644 --- a/.gitignore +++ b/.gitignore @@ -137,7 +137,7 @@ _darcs/ /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/ diff --git a/aclocal.m4 b/aclocal.m4 index ed3d006..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], @@ -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 66bff3e..0b67b17 100755 --- a/boot +++ b/boot @@ -3,13 +3,19 @@ use strict; use Cwd; +use File::Path 'rmtree'; +use File::Basename; my %required_tag; my $validate; +my $curdir; $required_tag{"-"} = 1; $validate = 0; +$curdir = &cwd() + or die "Can't find current directory: $!"; + while ($#ARGV ne -1) { my $arg = shift @ARGV; @@ -24,7 +30,7 @@ while ($#ARGV ne -1) { } } -{ +sub sanity_check_line_endings { local $/ = undef; open FILE, "packages" or die "Couldn't open file: $!"; binmode FILE; @@ -42,59 +48,168 @@ EOF } } -# Create libraries/*/{ghc.mk,GNUmakefile} -system("/usr/bin/perl", "-w", "boot-pkgs") == 0 - or die "Running boot-pkgs failed: $?"; +sub sanity_check_tree { + my $tag; + my $dir; -my $tag; -my $dir; -my $curdir; + # Check that we have all boot packages. + open PACKAGES, "< packages"; + while () { + if (/^#/) { + # Comment; do nothing + } + elsif (/^([a-zA-Z0-9\/.-]+) +([^ ]+) +[^ ]+ +[^ ]+ +[^ ]+$/) { + $dir = $1; + $tag = $2; + + # If $tag is not "-" then it is an optional repository, so its + # absence isn't an error. + if (defined($required_tag{$tag})) { + # We would like to just check for a .git directory here, + # but in an lndir tree we avoid making .git directories, + # so it doesn't exist. We therefore require that every repo + # has a LICENSE file instead. + if (! -f "$dir/LICENSE") { + print STDERR "Error: $dir/LICENSE doesn't exist.\n"; + die "Maybe you haven't done './sync-all get'?"; + } + } + } + else { + die "Bad line in packages file: $_"; + } + } + close PACKAGES; +} -$curdir = &cwd() - or die "Can't find current directory: $!"; +# Create libraries/*/{ghc.mk,GNUmakefile} +sub boot_pkgs { + my @library_dirs = (); + my @tarballs = glob("libraries/tarballs/*"); + + my $tarball; + my $package; + my $stamp; + + for $tarball (@tarballs) { + $package = $tarball; + $package =~ s#^libraries/tarballs/##; + $package =~ s/-[0-9.]*(-snapshot)?\.tar\.gz$//; + + # Sanity check, so we don't rmtree the wrong thing below + if (($package eq "") || ($package =~ m#[/.\\]#)) { + die "Bad package name: $package"; + } -# Check that we have all boot packages. -open PACKAGES, "< packages"; -while () { - if (/^#/) { - # Comment; do nothing + if (-d "libraries/$package/_darcs") { + print "Ignoring libraries/$package as it looks like a darcs checkout\n" + } + elsif (-d "libraries/$package/.git") { + print "Ignoring libraries/$package as it looks like a git checkout\n" + } + else { + if (! -d "libraries/stamp") { + mkdir "libraries/stamp"; + } + $stamp = "libraries/stamp/$package"; + if ((! -d "libraries/$package") || (! -f "$stamp") + || ((-M "libraries/stamp/$package") > (-M $tarball))) { + print "Unpacking $package\n"; + if (-d "libraries/$package") { + &rmtree("libraries/$package") + or die "Can't remove libraries/$package: $!"; + } + mkdir "libraries/$package" + or die "Can't create libraries/$package: $!"; + system ("sh", "-c", "cd 'libraries/$package' && { cat ../../$tarball | gzip -d | tar xf - ; } && mv */* .") == 0 + or die "Failed to unpack $package"; + open STAMP, "> $stamp" + or die "Failed to open stamp file: $!"; + close STAMP + or die "Failed to close stamp file: $!"; + } + } } - elsif (/^([a-zA-Z0-9\/.-]+) +([^ ]+) +[^ ]+ +[^ ]+ +[^ ]+$/) { - $dir = $1; - $tag = $2; - - # If $tag is not "-" then it is an optional repository, so its - # absence isn't an error. - if (defined($required_tag{$tag})) { - # We would like to just check for a .git directory here, - # but in an lndir tree we avoid making .git directories, - # so it doesn't exist. We therefore require that every repo - # has a LICENSE file instead. - if (! -f "$dir/LICENSE") { - print STDERR "Error: $dir/LICENSE doesn't exist.\n"; - die "Maybe you haven't done './sync-all get'?"; + + for $package (glob "libraries/*/") { + $package =~ s/\/$//; + my $pkgs = "$package/ghc-packages"; + if (-f $pkgs) { + open PKGS, "< $pkgs" + or die "Failed to open $pkgs: $!"; + while () { + chomp; + s/\r//g; + if (/.+/) { + push @library_dirs, "$package/$_"; + } } } + else { + push @library_dirs, $package; + } } - else { - die "Bad line in packages file: $_"; + + for $package (@library_dirs) { + my $dir = &basename($package); + my @cabals = glob("$package/*.cabal"); + if ($#cabals > 0) { + die "Too many .cabal file in $package\n"; + } + if ($#cabals eq 0) { + my $cabal = $cabals[0]; + my $pkg; + my $top; + if (-f $cabal) { + $pkg = $cabal; + $pkg =~ s#.*/##; + $pkg =~ s/\.cabal$//; + $top = $package; + $top =~ s#[^/]+#..#g; + $dir = $package; + $dir =~ s#^libraries/##g; + + print "Creating $package/ghc.mk\n"; + open GHCMK, "> $package/ghc.mk" + or die "Opening $package/ghc.mk failed: $!"; + print GHCMK "${package}_PACKAGE = ${pkg}\n"; + print GHCMK "${package}_dist-install_GROUP = libraries\n"; + print GHCMK "\$(eval \$(call build-package,${package},dist-install,\$(if \$(filter ${dir},\$(STAGE2_PACKAGES)),2,1)))\n"; + close GHCMK + or die "Closing $package/ghc.mk failed: $!"; + + print "Creating $package/GNUmakefile\n"; + open GNUMAKEFILE, "> $package/GNUmakefile" + or die "Opening $package/GNUmakefile failed: $!"; + print GNUMAKEFILE "dir = ${package}\n"; + print GNUMAKEFILE "TOP = ${top}\n"; + print GNUMAKEFILE "include \$(TOP)/mk/sub-makefile.mk\n"; + print GNUMAKEFILE "FAST_MAKE_OPTS += stage=0\n"; + close GNUMAKEFILE + or die "Closing $package/GNUmakefile failed: $!"; + } + } } } -close PACKAGES; # autoreconf everything that needs it. -foreach $dir (".", glob("libraries/*/")) { - if (-f "$dir/configure.ac") { - print "Booting $dir\n"; - chdir $dir or die "can't change to $dir: $!"; - system("autoreconf") == 0 - or die "Running autoreconf failed with exitcode $?"; - chdir $curdir or die "can't change to $curdir: $!"; +sub autoreconf { + my $dir; + + foreach $dir (".", glob("libraries/*/")) { + if (-f "$dir/configure.ac") { + print "Booting $dir\n"; + chdir $dir or die "can't change to $dir: $!"; + system("autoreconf") == 0 + or die "Running autoreconf failed with exitcode $?"; + chdir $curdir or die "can't change to $curdir: $!"; + } } } -if ($validate eq 0 && ! -f "mk/build.mk") { - print < (-M $tarball))) { - print "Unpacking $package\n"; - if (-d "libraries/$package") { - &rmtree("libraries/$package") - or die "Can't remove libraries/$package: $!"; - } - mkdir "libraries/$package" - or die "Can't create libraries/$package: $!"; - system ("sh", "-c", "cd 'libraries/$package' && { cat ../../$tarball | gzip -d | tar xf - ; } && mv */* .") == 0 - or die "Failed to unpack $package"; - open STAMP, "> $stamp" - or die "Failed to open stamp file: $!"; - close STAMP - or die "Failed to close stamp file: $!"; - } - } -} - -for $package (glob "libraries/*/") { - $package =~ s/\/$//; - my $pkgs = "$package/ghc-packages"; - if (-f $pkgs) { - open PKGS, "< $pkgs" - or die "Failed to open $pkgs: $!"; - while () { - chomp; - s/\r//g; - if (/.+/) { - push @library_dirs, "$package/$_"; - } - } - } - else { - push @library_dirs, $package; - } -} - -for $package (@library_dirs) { - my $dir = &basename($package); - my @cabals = glob("$package/*.cabal"); - if ($#cabals > 0) { - die "Too many .cabal file in $package\n"; - } - if ($#cabals eq 0) { - my $cabal = $cabals[0]; - my $pkg; - my $top; - if (-f $cabal) { - $pkg = $cabal; - $pkg =~ s#.*/##; - $pkg =~ s/\.cabal$//; - $top = $package; - $top =~ s#[^/]+#..#g; - $dir = $package; - $dir =~ s#^libraries/##g; - - print "Creating $package/ghc.mk\n"; - open GHCMK, "> $package/ghc.mk" - or die "Opening $package/ghc.mk failed: $!"; - print GHCMK "${package}_PACKAGE = ${pkg}\n"; - print GHCMK "${package}_dist-install_GROUP = libraries\n"; - print GHCMK "\$(eval \$(call build-package,${package},dist-install,\$(if \$(filter ${dir},\$(STAGE2_PACKAGES)),2,1)))\n"; - close GHCMK - or die "Closing $package/ghc.mk failed: $!"; - - print "Creating $package/GNUmakefile\n"; - open GNUMAKEFILE, "> $package/GNUmakefile" - or die "Opening $package/GNUmakefile failed: $!"; - print GNUMAKEFILE "dir = ${package}\n"; - print GNUMAKEFILE "TOP = ${top}\n"; - print GNUMAKEFILE "include \$(TOP)/mk/sub-makefile.mk\n"; - print GNUMAKEFILE "FAST_MAKE_OPTS += stage=0\n"; - close GNUMAKEFILE - or die "Closing $package/GNUmakefile failed: $!"; - } - } -} - diff --git a/compiler/Makefile.local b/compiler/Makefile.local deleted file mode 100644 index 1d53451..0000000 --- a/compiler/Makefile.local +++ /dev/null @@ -1,75 +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. -TOP=.. -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) - -# Now add flags from the GHC build system to the Cabal build: -GHC_CC_OPTS += $(addprefix -optc, $(MACOSX_DEPLOYMENT_CC_OPTS)) -GHC_OPTS += $(SRC_HC_OPTS) -GHC_OPTS += $(GhcHcOpts) -GHC_OPTS += $(GhcStage$(stage)HcOpts) -GHC_OPTS += $(addprefix -optc, $(MACOSX_DEPLOYMENT_CC_OPTS)) -LIB_LD_OPTS += $(addprefix -optl, $(MACOSX_DEPLOYMENT_LD_OPTS)) - -# XXX These didn't work in the old build system, according to the -# comment at least. We should actually handle them properly at some -# point: - -# Some .hs files #include other source files, but since ghc -M doesn't spit out -# these dependencies we have to include them manually. - -# We don't add dependencies on HsVersions.h, ghcautoconf.h, or ghc_boot_platform.h, -# because then modifying one of these files would force recompilation of everything, -# which is probably not what you want. However, it does mean you have to be -# careful to recompile stuff you need if you reconfigure or change HsVersions.h. - -# Aargh, these don't work properly anyway, because GHC's recompilation checker -# just reports "compilation NOT required". Do we have to add -fforce-recomp for each -# of these .hs files? I haven't done anything about this yet. - -# $(odir)/codeGen/Bitmap.$(way_)o : ../includes/MachDeps.h -# $(odir)/codeGen/CgCallConv.$(way_)o : ../includes/StgFun.h -# $(odir)/codeGen/CgProf.$(way_)o : ../includes/MachDeps.h -# $(odir)/codeGen/CgProf.$(way_)o : ../includes/Constants.h -# $(odir)/codeGen/CgProf.$(way_)o : ../includes/DerivedConstants.h -# $(odir)/codeGen/CgTicky.$(way_)o : ../includes/DerivedConstants.h -# $(odir)/codeGen/ClosureInfo.$(way_)o : ../includes/MachDeps.h -# $(odir)/codeGen/SMRep.$(way_)o : ../includes/MachDeps.h -# $(odir)/codeGen/SMRep.$(way_)o : ../includes/ClosureTypes.h -# $(odir)/ghci/ByteCodeAsm.$(way_)o : ../includes/Bytecodes.h -# $(odir)/ghci/ByteCodeFFI.$(way_)o : nativeGen/NCG.h -# $(odir)/ghci/ByteCodeInstr.$(way_)o : ../includes/MachDeps.h -# $(odir)/ghci/ByteCodeItbls.$(way_)o : ../includes/ClosureTypes.h -# $(odir)/ghci/ByteCodeItbls.$(way_)o : nativeGen/NCG.h -# $(odir)/main/Constants.$(way_)o : ../includes/MachRegs.h -# $(odir)/main/Constants.$(way_)o : ../includes/Constants.h -# $(odir)/main/Constants.$(way_)o : ../includes/MachDeps.h -# $(odir)/main/Constants.$(way_)o : ../includes/DerivedConstants.h -# $(odir)/main/Constants.$(way_)o : ../includes/GHCConstants.h -# $(odir)/nativeGen/AsmCodeGen.$(way_)o : nativeGen/NCG.h -# $(odir)/nativeGen/MachCodeGen.$(way_)o : nativeGen/NCG.h -# $(odir)/nativeGen/MachCodeGen.$(way_)o : ../includes/MachDeps.h -# $(odir)/nativeGen/MachInstrs.$(way_)o : nativeGen/NCG.h -# $(odir)/nativeGen/MachRegs.$(way_)o : nativeGen/NCG.h -# $(odir)/nativeGen/MachRegs.$(way_)o : ../includes/MachRegs.h -# $(odir)/nativeGen/PositionIndependentCode.$(way_)o : nativeGen/NCG.h -# $(odir)/nativeGen/PprMach.$(way_)o : nativeGen/NCG.h -# $(odir)/nativeGen/RegAllocInfo.$(way_)o : nativeGen/NCG.h -# $(odir)/typecheck/TcForeign.$(way_)o : nativeGen/NCG.h -# $(odir)/utils/Binary.$(way_)o : ../includes/MachDeps.h -# $(odir)/utils/FastMutInt.$(way_)o : ../includes/MachDeps.h -# $(PRIMOP_BITS) is defined in Makefile -# $(odir)/prelude/PrimOp.o: $(PRIMOP_BITS) - diff --git a/compiler/basicTypes/Module.lhs b/compiler/basicTypes/Module.lhs index c4bdba2..03f541e 100644 --- a/compiler/basicTypes/Module.lhs +++ b/compiler/basicTypes/Module.lhs @@ -155,6 +155,7 @@ addBootSuffixLocn locn \begin{code} -- | A ModuleName is essentially a simple string, e.g. @Data.List@. newtype ModuleName = ModuleName FastString + deriving Typeable instance Uniquable ModuleName where getUnique (ModuleName nm) = getUnique nm @@ -175,8 +176,6 @@ instance Binary ModuleName where put_ bh (ModuleName fs) = put_ bh fs get bh = do fs <- get bh; return (ModuleName fs) -INSTANCE_TYPEABLE0(ModuleName,moduleNameTc,"ModuleName") - instance Data ModuleName where -- don't traverse? toConstr _ = abstractConstr "ModuleName" @@ -224,7 +223,7 @@ data Module = Module { modulePackageId :: !PackageId, -- pkg-1.0 moduleName :: !ModuleName -- A.B.C } - deriving (Eq, Ord) + deriving (Eq, Ord, Typeable) instance Uniquable Module where getUnique (Module p n) = getUnique (packageIdFS p `appendFS` moduleNameFS n) @@ -236,8 +235,6 @@ instance Binary Module where put_ bh (Module p n) = put_ bh p >> 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/CmmCPS.hs b/compiler/cmm/CmmCPS.hs index b9f6db3..aad0037 100644 --- a/compiler/cmm/CmmCPS.hs +++ b/compiler/cmm/CmmCPS.hs @@ -112,12 +112,13 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) --------------- Stack layout ---------------- slotEnv <- run $ liveSlotAnal g + let spEntryMap = getSpEntryMap entry_off g mbpprTrace "live slot analysis results: " (ppr slotEnv) $ return () - let areaMap = layout procPoints slotEnv entry_off g + let areaMap = layout procPoints spEntryMap slotEnv entry_off g mbpprTrace "areaMap" (ppr areaMap) $ return () ------------ Manifest the stack pointer -------- - g <- run $ manifestSP areaMap entry_off g + g <- run $ manifestSP spEntryMap areaMap entry_off g dump Opt_D_dump_cmmz "after manifestSP" g -- UGH... manifestSP can require updates to the procPointMap. -- We can probably do something quicker here for the update... diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs index c14ad65..32fead3 100644 --- a/compiler/cmm/CmmLint.hs +++ b/compiler/cmm/CmmLint.hs @@ -153,6 +153,7 @@ lintTarget (CmmPrim {}) = return () checkCond :: CmmExpr -> CmmLint () checkCond (CmmMachOp mop _) | isComparisonMachOp mop = return () +checkCond (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth = return () -- constant values checkCond expr = cmmLintErr (hang (text "expression is not a conditional:") 2 (ppr expr)) 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/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs index d0d54d9..fbe979b 100644 --- a/compiler/cmm/CmmProcPoint.hs +++ b/compiler/cmm/CmmProcPoint.hs @@ -378,6 +378,8 @@ add_CopyOuts protos procPoints g = foldGraphBlocks mb_copy_out (return mapEmpty) -- 4. build info tables for the procedures -- and update the info table for -- the SRTs in the entry procedure as well. -- Input invariant: A block should only be reachable from a single ProcPoint. +-- ToDo: use the _ret naming convention that the old code generator +-- used. -- EZY splitAtProcPoints :: CLabel -> ProcPointSet-> ProcPointSet -> BlockEnv Status -> CmmTop -> FuelUniqSM [CmmTop] splitAtProcPoints entry_label callPPs procPoints procMap diff --git a/compiler/cmm/CmmStackLayout.hs b/compiler/cmm/CmmStackLayout.hs index 01543c4..c0fb6af 100644 --- a/compiler/cmm/CmmStackLayout.hs +++ b/compiler/cmm/CmmStackLayout.hs @@ -13,7 +13,7 @@ module CmmStackLayout ( SlotEnv, liveSlotAnal, liveSlotTransfers, removeLiveSlotDefs - , layout, manifestSP, igraph, areaBuilder + , getSpEntryMap, layout, manifestSP, igraph, areaBuilder , stubSlotsOnDeath ) -- to help crash early during debugging where @@ -195,7 +195,7 @@ liveLastOut env l = type Set x = Map x () data IGraphBuilder n = Builder { foldNodes :: forall z. SubArea -> (n -> z -> z) -> z -> z - , _wordsOccupied :: AreaMap -> AreaMap -> n -> [Int] + , _wordsOccupied :: AreaSizeMap -> AreaMap -> n -> [Int] } areaBuilder :: IGraphBuilder Area @@ -242,10 +242,13 @@ igraph builder env g = foldr interfere Map.empty (postorderDfs g) -- what's the highest offset (in bytes) used in each Area? -- We'll need to allocate that much space for each Area. +-- Mapping of areas to area sizes (not offsets!) +type AreaSizeMap = AreaMap + -- JD: WHY CAN'T THIS COME FROM THE slot-liveness info? -getAreaSize :: ByteOff -> CmmGraph -> AreaMap +getAreaSize :: ByteOff -> CmmGraph -> AreaSizeMap -- The domain of the returned mapping consists only of Areas - -- used for (a) variable spill slots, and (b) parameter passing ares for calls + -- used for (a) variable spill slots, and (b) parameter passing areas for calls getAreaSize entry_off g = foldGraphBlocks (foldBlockNodesF3 (first, add_regslots, last)) (Map.singleton (CallArea Old) entry_off) g @@ -266,10 +269,11 @@ getAreaSize entry_off g = -- The 'max' is important. Two calls, to f and g, might share a common -- continuation (and hence a common CallArea), but their number of overflow -- parameters might differ. + -- EZY: Ought to use insert with combining function... -- Find the Stack slots occupied by the subarea's conflicts -conflictSlots :: Ord x => IGPair x -> AreaMap -> AreaMap -> SubArea -> Set Int +conflictSlots :: Ord x => IGPair x -> AreaSizeMap -> AreaMap -> SubArea -> Set Int conflictSlots (ig, Builder foldNodes wordsOccupied) areaSize areaMap subarea = foldNodes subarea foldNode Map.empty where foldNode n set = Map.foldRightWithKey conflict set $ Map.findWithDefault Map.empty n ig @@ -278,10 +282,10 @@ conflictSlots (ig, Builder foldNodes wordsOccupied) areaSize areaMap subarea = liveInSlots areaMap n set = foldr setAdd set (wordsOccupied areaSize areaMap n) setAdd w s = Map.insert w () s --- Find any open space on the stack, starting from the offset. --- If the area is a CallArea or a spill slot for a pointer, then it must --- be word-aligned. -freeSlotFrom :: Ord x => IGPair x -> AreaMap -> Int -> AreaMap -> Area -> Int +-- Find any open space for 'area' on the stack, starting from the +-- 'offset'. If the area is a CallArea or a spill slot for a pointer, +-- then it must be word-aligned. +freeSlotFrom :: Ord x => IGPair x -> AreaSizeMap -> Int -> AreaMap -> Area -> Int freeSlotFrom ig areaSize offset areaMap area = let size = Map.lookup area areaSize `orElse` 0 conflicts = conflictSlots ig areaSize areaMap (area, size, size) @@ -299,11 +303,24 @@ freeSlotFrom ig areaSize offset areaMap area = in findSpace (align (offset + size)) size -- Find an open space on the stack, and assign it to the area. -allocSlotFrom :: Ord x => IGPair x -> AreaMap -> Int -> AreaMap -> Area -> AreaMap +allocSlotFrom :: Ord x => IGPair x -> AreaSizeMap -> Int -> AreaMap -> Area -> AreaMap allocSlotFrom ig areaSize from areaMap area = if Map.member area areaMap then areaMap else Map.insert area (freeSlotFrom ig areaSize from areaMap area) areaMap +-- Figure out all of the offsets from the slot location; this will be +-- non-zero for procpoints. +type SpEntryMap = BlockEnv Int +getSpEntryMap :: Int -> CmmGraph -> SpEntryMap +getSpEntryMap entry_off g@(CmmGraph {g_entry = entry}) + = foldGraphBlocks add_sp_off (mapInsert entry entry_off emptyBlockMap) g + where add_sp_off :: CmmBlock -> BlockEnv Int -> BlockEnv Int + add_sp_off b env = + case lastNode b of + CmmCall {cml_cont=Just succ, cml_ret_args=off} -> mapInsert succ off env + CmmForeignCall {succ=succ} -> mapInsert succ wORD_SIZE env + _ -> env + -- | Greedy stack layout. -- Compute liveness, build the interference graph, and allocate slots for the areas. -- We visit each basic block in a (generally) forward order. @@ -326,12 +343,16 @@ allocSlotFrom ig areaSize from areaMap area = -- Note: The stack pointer only has to be younger than the youngest live stack slot -- at proc points. Otherwise, the stack pointer can point anywhere. -layout :: ProcPointSet -> SlotEnv -> ByteOff -> CmmGraph -> AreaMap +layout :: ProcPointSet -> SpEntryMap -> SlotEnv -> ByteOff -> CmmGraph -> AreaMap -- The domain of the returned map includes an Area for EVERY block -- including each block that is not the successor of a call (ie is not a proc-point) --- That's how we return the info of what the SP should be at the entry of every block +-- That's how we return the info of what the SP should be at the entry of every non +-- procpoint block. However, note that procpoint blocks have their +-- /slot/ stored, which is not necessarily the value of the SP on entry +-- to the block (in fact, it probably isn't, due to argument passing). +-- See [Procpoint Sp offset] -layout procPoints env entry_off g = +layout procPoints spEntryMap env entry_off g = let ig = (igraph areaBuilder env g, areaBuilder) env' bid = mapLookup bid env `orElse` panic "unknown blockId in igraph" areaSize = getAreaSize entry_off g @@ -370,21 +391,87 @@ layout procPoints env entry_off g = allocMid m areaMap = foldSlotsDefd alloc' (foldSlotsUsed alloc' areaMap m) m allocLast bid l areaMap = foldr (setSuccSPs inSp) areaMap' (successors l) - where inSp = expectJust "sp in" $ Map.lookup (CallArea (Young bid)) areaMap + where inSp = slot + spOffset -- [Procpoint Sp offset] + -- If it's not in the map, we should use our previous + -- calculation unchanged. + spOffset = mapLookup bid spEntryMap `orElse` 0 + slot = expectJust "slot in" $ Map.lookup (CallArea (Young bid)) areaMap areaMap' = foldSlotsDefd alloc' (foldSlotsUsed alloc' areaMap l) l alloc' areaMap (a@(RegSlot _), _, _) = allocVarSlot areaMap a alloc' areaMap _ = areaMap - initMap = Map.insert (CallArea (Young (g_entry g))) 0 $ - Map.insert (CallArea Old) 0 Map.empty - + initMap = Map.insert (CallArea (Young (g_entry g))) 0 + . Map.insert (CallArea Old) 0 + $ Map.empty + areaMap = foldl layoutAreas initMap (postorderDfs g) in -- pprTrace "ProcPoints" (ppr procPoints) $ - -- pprTrace "Area SizeMap" (ppr areaSize) $ - -- pprTrace "Entry SP" (ppr entrySp) $ - -- pprTrace "Area Map" (ppr areaMap) $ + -- pprTrace "Area SizeMap" (ppr areaSize) $ + -- pprTrace "Entry offset" (ppr entry_off) $ + -- pprTrace "Area Map" (ppr areaMap) $ areaMap +{- Note [Procpoint Sp offset] + +The calculation of inSp is a little tricky. (Un)fortunately, if you get +it wrong, you will get inefficient but correct code. You know you've +got it wrong if the generated stack pointer bounces up and down for no +good reason. + +Why can't we just set inSp to the location of the slot? (This is what +the code used to do.) The trouble is when we actually hit the proc +point the start of the slot will not be the same as the actual Sp due +to argument passing: + + a: + I32[(young + 4)] = cde; + // Stack pointer is moved to young end (bottom) of young for call + // +-------+ + // | arg 1 | + // +-------+ <- Sp + call (I32[foobar::I32])(...) returns to Just b (4) (4) with update frame 4; + b: + // After call, stack pointer is above the old end (top) of + // young (the difference is spOffset) + // +-------+ <- Sp + // | arg 1 | + // +-------+ + +If we blithely set the Sp to be the same as the slot (the young end of +young), an adjustment will be necessary when we go to the next block. +This is wasteful. So, instead, for the next block after a procpoint, +the actual Sp should be set to the same as the true Sp when we just +entered the procpoint. Then manifestSP will automatically do the right +thing. + +Questions you may ask: + +1. Why don't we need to change the mapping for the procpoint itself? + Because manifestSP does its own calculation of the true stack value, + manifestSP will notice the discrepancy between the actual stack + pointer and the slot start, and adjust all of its memory accesses + accordingly. So the only problem is when we adjust the Sp in + preparation for the successor block; that's why this code is here and + not in setSuccSPs. + +2. Why don't we make the procpoint call area and the true offset match + up? If we did that, we would never use memory above the true value + of the stack pointer, thus wasting all of the stack we used to store + arguments. You might think that some clever changes to the slot + offsets, using negative offsets, might fix it, but this does not make + semantic sense. + +3. If manifestSP is already calculating the true stack value, why we can't + do this trick inside manifestSP itself? The reason is that if two + branches join with inconsistent SPs, one of them has to be fixed: we + can't know what the fix should be without already knowing what the + chosen location of SP is on the next successor. (This is + the "succ already knows incoming SP" case), This calculation cannot + be easily done in manifestSP, since it processes the nodes + /backwards/. So we need to have figured this out before we hit + manifestSP. +-} + -- After determining the stack layout, we can: -- 1. Replace references to stack Areas with addresses relative to the stack -- pointer. @@ -394,8 +481,8 @@ layout procPoints env entry_off g = -- stack pointer to be younger than the live values on the stack at proc points. -- 3. Compute the maximum stack offset used in the procedure and replace -- the stack high-water mark with that offset. -manifestSP :: AreaMap -> ByteOff -> CmmGraph -> FuelUniqSM CmmGraph -manifestSP areaMap entry_off g@(CmmGraph {g_entry=entry}) = +manifestSP :: SpEntryMap -> AreaMap -> ByteOff -> CmmGraph -> FuelUniqSM CmmGraph +manifestSP spEntryMap areaMap entry_off g@(CmmGraph {g_entry=entry}) = ofBlockMap entry `liftM` foldl replB (return mapEmpty) (postorderDfs g) where slot a = -- pprTrace "slot" (ppr a) $ Map.lookup a areaMap `orElse` panic "unallocated Area" @@ -404,13 +491,6 @@ manifestSP areaMap entry_off g@(CmmGraph {g_entry=entry}) = sp_high = maxSlot slot g proc_entry_sp = slot (CallArea Old) + entry_off - add_sp_off :: CmmBlock -> BlockEnv Int -> BlockEnv Int - add_sp_off b env = - case lastNode b of - CmmCall {cml_cont=Just succ, cml_ret_args=off} -> mapInsert succ off env - CmmForeignCall {succ=succ} -> mapInsert succ wORD_SIZE env - _ -> env - spEntryMap = foldGraphBlocks add_sp_off (mapInsert entry entry_off emptyBlockMap) g spOffset id = mapLookup id spEntryMap `orElse` 0 sp_on_entry id | id == entry = proc_entry_sp @@ -427,10 +507,26 @@ manifestSP areaMap entry_off g@(CmmGraph {g_entry=entry}) = where spIn = sp_on_entry (entryLabel block) middle spOff m = mapExpDeep (replSlot spOff) m + -- XXX there shouldn't be any global registers in the + -- CmmCall, so there shouldn't be any slots in + -- CmmCall... check that... last spOff l = mapExpDeep (replSlot spOff) l replSlot spOff (CmmStackSlot a i) = CmmRegOff (CmmGlobal Sp) (spOff - (slot a + i)) replSlot _ (CmmLit CmmHighStackMark) = -- replacing the high water mark CmmLit (CmmInt (toInteger (max 0 (sp_high - proc_entry_sp))) (typeWidth bWord)) + -- Invariant: Sp is always greater than SpLim. Thus, if + -- the high water mark is zero, we can optimize away the + -- conditional branch. Relies on dead code elimination + -- to get rid of the dead GC blocks. + -- EZY: Maybe turn this into a guard that checks if a + -- statement is stack-check ish? Maybe we should make + -- an actual mach-op for it, so there's no chance of + -- mixing this up with something else... + replSlot _ (CmmMachOp (MO_U_Lt _) + [CmmMachOp (MO_Sub _) + [ CmmReg (CmmGlobal Sp) + , CmmLit (CmmInt 0 _)], + CmmReg (CmmGlobal SpLim)]) = CmmLit (CmmInt 0 wordWidth) replSlot _ e = e replLast :: MaybeC C (CmmNode C O) -> [CmmNode O O] -> CmmNode O C -> FuelUniqSM [CmmBlock] 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/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/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/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 9dd9cc7..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,7 +1028,7 @@ 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 verbFlags = getVerbFlags dflags diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 0914c32..ba862c5 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,8 +32,17 @@ 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] @@ -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 ) @@ -441,41 +450,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, @@ -485,8 +466,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. @@ -521,6 +500,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 @@ -643,8 +721,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, @@ -694,25 +772,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, @@ -721,25 +785,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, @@ -913,9 +959,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 @@ -1096,30 +1142,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 @@ -1318,7 +1364,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 ---------------------------------------------------- @@ -1835,18 +1881,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 {- ********************************************************************** @@ -1903,6 +1951,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 @@ -2117,7 +2169,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 @@ -2142,17 +2194,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' @@ -2224,30 +2275,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 f0c1111..6a5552f 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/StaticFlags.hs b/compiler/main/StaticFlags.hs index 049b61f..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. @@ -192,16 +192,12 @@ opt_IgnoreDotGhci = lookUp (fsLit "-ignore-dot-ghci") -- debugging options -- | Suppress all that is suppressable in core dumps. +-- Except for uniques, as some simplifier phases introduce new varibles that +-- have otherwise identical names. opt_SuppressAll :: Bool opt_SuppressAll = lookUp (fsLit "-dsuppress-all") --- | Suppress unique ids on variables. -opt_SuppressUniques :: Bool -opt_SuppressUniques - = lookUp (fsLit "-dsuppress-all") - || lookUp (fsLit "-dsuppress-uniques") - -- | Suppress all coercions, them replacing with '...' opt_SuppressCoercions :: Bool opt_SuppressCoercions @@ -232,10 +228,16 @@ opt_SuppressTypeSignatures = lookUp (fsLit "-dsuppress-all") || lookUp (fsLit "-dsuppress-type-signatures") +-- | Suppress unique ids on variables. +-- Except for uniques, as some simplifier phases introduce new variables that +-- have otherwise identical names. +opt_SuppressUniques :: Bool +opt_SuppressUniques + = lookUp (fsLit "-dsuppress-uniques") -- | Display case expressions with a single alternative as strict let bindings opt_PprCaseAsLet :: Bool -opt_PprCaseAsLet = lookUp (fsLit "-dppr-case-as-let") +opt_PprCaseAsLet = lookUp (fsLit "-dppr-case-as-let") -- | Set the maximum width of the dumps -- If GHC's command line options are bad then the options parser uses the 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/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index 7a38540..767dc99 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -378,10 +378,15 @@ cmmNativeGen dflags us cmm count , Nothing , mPprStats) + ---- generate jump tables + let tabled = + {-# SCC "generateJumpTables" #-} + alloced ++ generateJumpTables alloced + ---- shortcut branches let shorted = {-# SCC "shortcutBranches" #-} - shortcutBranches dflags alloced + shortcutBranches dflags tabled ---- sequence blocks let sequenced = @@ -609,6 +614,18 @@ makeFarBranches = id #endif -- ----------------------------------------------------------------------------- +-- Generate jump tables + +-- Analyzes all native code and generates data sections for all jump +-- table instructions. +generateJumpTables + :: [NatCmmTop Instr] -> [NatCmmTop Instr] +generateJumpTables xs = concatMap f xs + where f (CmmProc _ _ (ListGraph xs)) = concatMap g xs + f _ = [] + g (BasicBlock _ xs) = catMaybes (map generateJumpTableForInstr xs) + +-- ----------------------------------------------------------------------------- -- Shortcut branches shortcutBranches diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs index 29b9a54..c96badd 100644 --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -15,6 +15,7 @@ module PPC.CodeGen ( cmmTopCodeGen, + generateJumpTableForInstr, InstrBlock ) @@ -798,7 +799,7 @@ genJump (CmmLit (CmmLabel lbl)) genJump tree = do (target,code) <- getSomeReg tree - return (code `snocOL` MTCTR target `snocOL` BCTR []) + return (code `snocOL` MTCTR target `snocOL` BCTR [] Nothing) -- ----------------------------------------------------------------------------- @@ -1126,22 +1127,12 @@ genSwitch expr ids dflags <- getDynFlagsNat dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl (tableReg,t_code) <- getSomeReg $ dynRef - let - jumpTable = map jumpTableEntryRel ids - - jumpTableEntryRel Nothing - = CmmStaticLit (CmmInt 0 wordWidth) - jumpTableEntryRel (Just blockid) - = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0) - where blockLabel = mkAsmTempLabel (getUnique blockid) - - code = e_code `appOL` t_code `appOL` toOL [ - LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable), + let code = e_code `appOL` t_code `appOL` toOL [ SLW tmp reg (RIImm (ImmInt 2)), LD II32 tmp (AddrRegReg tableReg tmp), ADD tmp tmp (RIReg tableReg), MTCTR tmp, - BCTR [ id | Just id <- ids ] + BCTR ids (Just lbl) ] return code | otherwise @@ -1149,19 +1140,27 @@ genSwitch expr ids (reg,e_code) <- getSomeReg expr tmp <- getNewRegNat II32 lbl <- getNewLabelNat - let - jumpTable = map jumpTableEntry ids - - code = e_code `appOL` toOL [ - LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable), + let code = e_code `appOL` toOL [ SLW tmp reg (RIImm (ImmInt 2)), ADDIS tmp tmp (HA (ImmCLbl lbl)), LD II32 tmp (AddrRegImm tmp (LO (ImmCLbl lbl))), MTCTR tmp, - BCTR [ id | Just id <- ids ] + BCTR ids (Just lbl) ] return code +generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop Instr) +generateJumpTableForInstr (BCTR ids (Just lbl)) = + let jumpTable + | opt_PIC = map jumpTableEntryRel ids + | otherwise = map jumpTableEntry ids + where jumpTableEntryRel Nothing + = CmmStaticLit (CmmInt 0 wordWidth) + jumpTableEntryRel (Just blockid) + = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0) + where blockLabel = mkAsmTempLabel (getUnique blockid) + in Just (CmmData ReadOnlyData (CmmDataLabel lbl : jumpTable)) +generateJumpTableForInstr _ = Nothing -- ----------------------------------------------------------------------------- -- 'condIntReg' and 'condFltReg': condition codes into registers diff --git a/compiler/nativeGen/PPC/Instr.hs b/compiler/nativeGen/PPC/Instr.hs index 6aeccd3..0288f1b 100644 --- a/compiler/nativeGen/PPC/Instr.hs +++ b/compiler/nativeGen/PPC/Instr.hs @@ -104,7 +104,7 @@ data Instr | JMP CLabel -- same as branch, -- but with CLabel instead of block ID | MTCTR Reg - | BCTR [BlockId] -- with list of local destinations + | BCTR [Maybe BlockId] (Maybe CLabel) -- with list of local destinations, and jump table location if necessary | BL CLabel [Reg] -- with list of argument regs | BCTRL [Reg] @@ -184,7 +184,7 @@ ppc_regUsageOfInstr instr BCC _ _ -> noUsage BCCFAR _ _ -> noUsage MTCTR reg -> usage ([reg],[]) - BCTR _ -> noUsage + BCTR _ _ -> noUsage BL _ params -> usage (params, callClobberedRegs) BCTRL params -> usage (params, callClobberedRegs) ADD reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) @@ -257,7 +257,7 @@ ppc_patchRegsOfInstr instr env BCC cond lbl -> BCC cond lbl BCCFAR cond lbl -> BCCFAR cond lbl MTCTR reg -> MTCTR (env reg) - BCTR targets -> BCTR targets + BCTR targets lbl -> BCTR targets lbl BL imm argRegs -> BL imm argRegs -- argument regs BCTRL argRegs -> BCTRL argRegs -- cannot be remapped ADD reg1 reg2 ri -> ADD (env reg1) (env reg2) (fixRI ri) @@ -326,7 +326,7 @@ ppc_jumpDestsOfInstr insn = case insn of BCC _ id -> [id] BCCFAR _ id -> [id] - BCTR targets -> targets + BCTR targets _ -> [id | Just id <- targets] _ -> [] @@ -338,7 +338,7 @@ ppc_patchJumpInstr insn patchF = case insn of BCC cc id -> BCC cc (patchF id) BCCFAR cc id -> BCCFAR cc (patchF id) - BCTR _ -> error "Cannot patch BCTR" + BCTR ids lbl -> BCTR (map (fmap patchF) ids) lbl _ -> insn diff --git a/compiler/nativeGen/PPC/Ppr.hs b/compiler/nativeGen/PPC/Ppr.hs index 9fb86c0..44a6a7c 100644 --- a/compiler/nativeGen/PPC/Ppr.hs +++ b/compiler/nativeGen/PPC/Ppr.hs @@ -545,7 +545,7 @@ pprInstr (MTCTR reg) = hcat [ char '\t', pprReg reg ] -pprInstr (BCTR _) = hcat [ +pprInstr (BCTR _ _) = hcat [ char '\t', ptext (sLit "bctr") ] diff --git a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs index 903082f..ef6ae9b 100644 --- a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs +++ b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs @@ -190,7 +190,7 @@ joinToTargets_again _ -> let instr' = patchJumpInstr instr (\bid -> if bid == dest then mkBlockId fixup_block_id - else dest) + else bid) -- no change! in joinToTargets' block_live (block : new_blocks) block_id instr' dests diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs index d08d10d..beb48d6 100644 --- a/compiler/nativeGen/SPARC/CodeGen.hs +++ b/compiler/nativeGen/SPARC/CodeGen.hs @@ -8,6 +8,7 @@ module SPARC.CodeGen ( cmmTopCodeGen, + generateJumpTableForInstr, InstrBlock ) @@ -299,15 +300,11 @@ genSwitch expr ids dst <- getNewRegNat II32 label <- getNewLabelNat - let jumpTable = map jumpTableEntry ids return $ e_code `appOL` toOL - -- the jump table - [ LDATA ReadOnlyData (CmmDataLabel label : jumpTable) - - -- load base of jump table - , SETHI (HI (ImmCLbl label)) base_reg + [ -- load base of jump table + SETHI (HI (ImmCLbl label)) base_reg , OR False base_reg (RIImm $ LO $ ImmCLbl label) base_reg -- the addrs in the table are 32 bits wide.. @@ -315,6 +312,11 @@ genSwitch expr ids -- load and jump to the destination , LD II32 (AddrRegReg base_reg offset_reg) dst - , JMP_TBL (AddrRegImm dst (ImmInt 0)) [i | Just i <- ids] + , JMP_TBL (AddrRegImm dst (ImmInt 0)) ids label , NOP ] +generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop Instr) +generateJumpTableForInstr (JMP_TBL _ ids label) = + let jumpTable = map jumpTableEntry ids + in Just (CmmData ReadOnlyData (CmmDataLabel label : jumpTable)) +generateJumpTableForInstr _ = Nothing diff --git a/compiler/nativeGen/SPARC/Instr.hs b/compiler/nativeGen/SPARC/Instr.hs index 79b4629..93f4d27 100644 --- a/compiler/nativeGen/SPARC/Instr.hs +++ b/compiler/nativeGen/SPARC/Instr.hs @@ -37,6 +37,7 @@ import RegClass import Reg import Size +import CLabel import BlockId import OldCmm import FastString @@ -194,7 +195,7 @@ data Instr -- With a tabled jump we know all the possible destinations. -- We also need this info so we can work out what regs are live across the jump. -- - | JMP_TBL AddrMode [BlockId] + | JMP_TBL AddrMode [Maybe BlockId] CLabel | CALL (Either Imm Reg) Int Bool -- target, args, terminal @@ -247,7 +248,7 @@ sparc_regUsageOfInstr instr FxTOy _ _ r1 r2 -> usage ([r1], [r2]) JMP addr -> usage (regAddr addr, []) - JMP_TBL addr _ -> usage (regAddr addr, []) + JMP_TBL addr _ _ -> usage (regAddr addr, []) CALL (Left _ ) _ True -> noUsage CALL (Left _ ) n False -> usage (argRegs n, callClobberedRegs) @@ -315,7 +316,7 @@ sparc_patchRegsOfInstr instr env = case instr of FxTOy s1 s2 r1 r2 -> FxTOy s1 s2 (env r1) (env r2) JMP addr -> JMP (fixAddr addr) - JMP_TBL addr ids -> JMP_TBL (fixAddr addr) ids + JMP_TBL addr ids l -> JMP_TBL (fixAddr addr) ids l CALL (Left i) n t -> CALL (Left i) n t CALL (Right r) n t -> CALL (Right (env r)) n t @@ -345,7 +346,7 @@ sparc_jumpDestsOfInstr insn = case insn of BI _ _ id -> [id] BF _ _ id -> [id] - JMP_TBL _ ids -> ids + JMP_TBL _ ids _ -> [id | Just id <- ids] _ -> [] @@ -354,6 +355,7 @@ sparc_patchJumpInstr insn patchF = case insn of BI cc annul id -> BI cc annul (patchF id) BF cc annul id -> BF cc annul (patchF id) + JMP_TBL n ids l -> JMP_TBL n (map (fmap patchF) ids) l _ -> insn diff --git a/compiler/nativeGen/SPARC/Ppr.hs b/compiler/nativeGen/SPARC/Ppr.hs index a63661f..0139680 100644 --- a/compiler/nativeGen/SPARC/Ppr.hs +++ b/compiler/nativeGen/SPARC/Ppr.hs @@ -543,7 +543,7 @@ pprInstr (BF cond b blockid) ] pprInstr (JMP addr) = (<>) (ptext (sLit "\tjmp\t")) (pprAddr addr) -pprInstr (JMP_TBL op _) = pprInstr (JMP op) +pprInstr (JMP_TBL op _ _) = pprInstr (JMP op) pprInstr (CALL (Left imm) n _) = hcat [ ptext (sLit "\tcall\t"), pprImm imm, comma, int n ] diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index 5df8f77..74f4073 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -20,6 +20,7 @@ module X86.CodeGen ( cmmTopCodeGen, + generateJumpTableForInstr, InstrBlock ) @@ -1932,16 +1933,7 @@ genSwitch expr ids dflags <- getDynFlagsNat dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl (tableReg,t_code) <- getSomeReg $ dynRef - let - jumpTable = map jumpTableEntryRel ids - - jumpTableEntryRel Nothing - = CmmStaticLit (CmmInt 0 wordWidth) - jumpTableEntryRel (Just blockid) - = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0) - where blockLabel = mkAsmTempLabel (getUnique blockid) - - op = OpAddr (AddrBaseIndex (EABaseReg tableReg) + let op = OpAddr (AddrBaseIndex (EABaseReg tableReg) (EAIndex reg wORD_SIZE) (ImmInt 0)) #if x86_64_TARGET_ARCH @@ -1954,8 +1946,7 @@ genSwitch expr ids code = e_code `appOL` t_code `appOL` toOL [ ADD (intSize wordWidth) op (OpReg tableReg), - JMP_TBL (OpReg tableReg) [ id | Just id <- ids ], - LDATA Text (CmmDataLabel lbl : jumpTable) + JMP_TBL (OpReg tableReg) ids Text lbl, ] #else -- HACK: On x86_64 binutils<2.17 is only able to generate PC32 @@ -1965,20 +1956,18 @@ genSwitch expr ids -- conjunction with the hack in PprMach.hs/pprDataItem once -- binutils 2.17 is standard. code = e_code `appOL` t_code `appOL` toOL [ - LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable), MOVSxL II32 (OpAddr (AddrBaseIndex (EABaseReg tableReg) (EAIndex reg wORD_SIZE) (ImmInt 0))) (OpReg reg), ADD (intSize wordWidth) (OpReg reg) (OpReg tableReg), - JMP_TBL (OpReg tableReg) [ id | Just id <- ids ] + JMP_TBL (OpReg tableReg) ids ReadOnlyData lbl ] #endif #else code = e_code `appOL` t_code `appOL` toOL [ - LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable), ADD (intSize wordWidth) op (OpReg tableReg), - JMP_TBL (OpReg tableReg) [ id | Just id <- ids ] + JMP_TBL (OpReg tableReg) ids ReadOnlyData lbl ] #endif return code @@ -1987,15 +1976,28 @@ genSwitch expr ids (reg,e_code) <- getSomeReg expr lbl <- getNewLabelNat let - jumpTable = map jumpTableEntry ids op = OpAddr (AddrBaseIndex EABaseNone (EAIndex reg wORD_SIZE) (ImmCLbl lbl)) code = e_code `appOL` toOL [ - LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable), - JMP_TBL op [ id | Just id <- ids ] + JMP_TBL op ids ReadOnlyData lbl ] -- in return code +generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop Instr) +generateJumpTableForInstr (JMP_TBL _ ids section lbl) = Just (createJumpTable ids section lbl) +generateJumpTableForInstr _ = Nothing + +createJumpTable ids section lbl + = let jumpTable + | opt_PIC = + let jumpTableEntryRel Nothing + = CmmStaticLit (CmmInt 0 wordWidth) + jumpTableEntryRel (Just blockid) + = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0) + where blockLabel = mkAsmTempLabel (getUnique blockid) + in map jumpTableEntryRel ids + | otherwise = map jumpTableEntry ids + in CmmData section (CmmDataLabel lbl : jumpTable) -- ----------------------------------------------------------------------------- -- 'condIntReg' and 'condFltReg': condition codes into registers diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs index a96452b..e934a6d 100644 --- a/compiler/nativeGen/X86/Instr.hs +++ b/compiler/nativeGen/X86/Instr.hs @@ -289,7 +289,11 @@ data Instr | JMP Operand | JXX Cond BlockId -- includes unconditional branches | JXX_GBL Cond Imm -- non-local version of JXX - | JMP_TBL Operand [BlockId] -- table jump + -- Table jump + | JMP_TBL Operand -- Address to jump to + [Maybe BlockId] -- Blocks in the jump table + Section -- Data section jump table should be put in + CLabel -- Label of jump table | CALL (Either Imm Reg) [Reg] -- Other things. @@ -350,7 +354,7 @@ x86_regUsageOfInstr instr JXX _ _ -> mkRU [] [] JXX_GBL _ _ -> mkRU [] [] JMP op -> mkRUR (use_R op) - JMP_TBL op _ -> mkRUR (use_R op) + JMP_TBL op _ _ _ -> mkRUR (use_R op) CALL (Left _) params -> mkRU params callClobberedRegs CALL (Right reg) params -> mkRU (reg:params) callClobberedRegs CLTD _ -> mkRU [eax] [edx] @@ -482,7 +486,7 @@ x86_patchRegsOfInstr instr env POP sz op -> patch1 (POP sz) op SETCC cond op -> patch1 (SETCC cond) op JMP op -> patch1 JMP op - JMP_TBL op ids -> patch1 JMP_TBL op $ ids + JMP_TBL op ids s lbl-> JMP_TBL (patchOp op) ids s lbl GMOV src dst -> GMOV (env src) (env dst) GLD sz src dst -> GLD sz (lookupAddr src) (env dst) @@ -579,7 +583,7 @@ x86_jumpDestsOfInstr x86_jumpDestsOfInstr insn = case insn of JXX _ id -> [id] - JMP_TBL _ ids -> ids + JMP_TBL _ ids _ _ -> [id | Just id <- ids] _ -> [] @@ -589,7 +593,8 @@ x86_patchJumpInstr x86_patchJumpInstr insn patchF = case insn of JXX cc id -> JXX cc (patchF id) - JMP_TBL _ _ -> error "Cannot patch JMP_TBL" + JMP_TBL op ids section lbl + -> JMP_TBL op (map (fmap patchF) ids) section lbl _ -> insn diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs index 5fe78e1..4c3454d 100644 --- a/compiler/nativeGen/X86/Ppr.hs +++ b/compiler/nativeGen/X86/Ppr.hs @@ -87,7 +87,17 @@ pprNatCmmTop (CmmProc info lbl (ListGraph blocks)) = <+> pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl) else empty #endif + $$ pprSizeDecl (if null info then lbl else entryLblToInfoLbl lbl) +-- | Output the ELF .size directive. +pprSizeDecl :: CLabel -> Doc +#if elf_OBJ_FORMAT +pprSizeDecl lbl = + ptext (sLit "\t.size") <+> pprCLabel_asm lbl + <> ptext (sLit ", .-") <> pprCLabel_asm lbl +#else +pprSizeDecl _ = empty +#endif pprBasicBlock :: NatBasicBlock Instr -> Doc pprBasicBlock (BasicBlock blockid instrs) = @@ -626,7 +636,7 @@ pprInstr (JXX_GBL cond imm) = pprCondInstr (sLit "j") cond (pprImm imm) pprInstr (JMP (OpImm imm)) = (<>) (ptext (sLit "\tjmp ")) (pprImm imm) pprInstr (JMP op) = (<>) (ptext (sLit "\tjmp *")) (pprOperand archWordSize op) -pprInstr (JMP_TBL op _) = pprInstr (JMP op) +pprInstr (JMP_TBL op _ _ _) = pprInstr (JMP op) pprInstr (CALL (Left imm) _) = (<>) (ptext (sLit "\tcall ")) (pprImm imm) pprInstr (CALL (Right reg) _) = (<>) (ptext (sLit "\tcall *")) (pprReg archWordSize reg) diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 61019b3..46f7488 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,35 +1873,35 @@ 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 .|. transformComprehensionsBit `setBitIf` xopt Opt_MonadComprehensions 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/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/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs index c527d82..6ddcff2 100644 --- a/compiler/simplCore/CoreMonad.lhs +++ b/compiler/simplCore/CoreMonad.lhs @@ -370,13 +370,21 @@ getCoreToDo dflags simpl_phase phase names iter = CoreDoPasses - [ maybe_strictness_before phase + $ [ maybe_strictness_before phase , CoreDoSimplify iter (base_mode { sm_phase = Phase phase , sm_names = names }) - , maybe_rule_check (Phase phase) - ] + , maybe_rule_check (Phase phase) ] + + -- Vectorisation can introduce a fair few common sub expressions involving + -- DPH primitives. For example, see the Reverse test from dph-examples. + -- We need to eliminate these common sub expressions before their definitions + -- are inlined in phase 2. The CSE introduces lots of v1 = v2 bindings, + -- so we also run simpl_gently to inline them. + ++ (if dopt Opt_Vectorise dflags && phase == 3 + then [CoreCSE, simpl_gently] + else []) vectorisation = runWhen (dopt Opt_Vectorise dflags) $ 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/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs index 4a049aa..fb6929a 100644 --- a/compiler/typecheck/TcInteract.lhs +++ b/compiler/typecheck/TcInteract.lhs @@ -1049,9 +1049,16 @@ doInteractWithInert (CIPCan { cc_id = id1, cc_flavor = ifl, cc_ip_nm = nm1, cc_i | nm1 == nm2 = -- See Note [When improvement happens] do { co_var <- newCoVar ty2 ty1 -- See Note [Efficient Orientation] - ; let flav = Wanted (combineCtLoc ifl wfl) - ; cans <- mkCanonical flav co_var - ; mkIRContinue "IP/IP fundep" workItem KeepInert cans } + ; let flav = Wanted (combineCtLoc ifl wfl) + ; cans <- mkCanonical flav co_var + ; case wfl of + Given {} -> pprPanic "Unexpected given IP" (ppr workItem) + Derived {} -> pprPanic "Unexpected derived IP" (ppr workItem) + Wanted {} -> + do { setIPBind (cc_id workItem) $ + EvCast id1 (mkSymCoercion (mkCoVarCoercion co_var)) + ; mkIRStopK "IP/IP interaction (solved)" cans } + } -- Never rewrite a given with a wanted equality, and a type function -- equality can never rewrite an equality. We rewrite LHS *and* RHS diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index 4b174e5..e511532 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, 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/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..96950cb 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 @@ -303,12 +305,15 @@ checkOS "$TargetOS" # Verify that the installed (bootstrap) GHC is capable of generating # code for the requested build platform. -if test "$BuildPlatform" != "$bootstrap_target" +if test "$BootingFromHc" = "NO" then - echo "This GHC (${WithGhc}) does not generate code for the build platform" - echo " GHC target platform : $bootstrap_target" - echo " Desired build platform : $BuildPlatform" - exit 1 + if test "$BuildPlatform" != "$bootstrap_target" + then + echo "This GHC (${WithGhc}) does not generate code for the build platform" + echo " GHC target platform : $bootstrap_target" + echo " Desired build platform : $BuildPlatform" + exit 1 + fi fi echo "GHC build : $BuildPlatform" @@ -537,7 +542,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 +583,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 +935,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/debugging.xml b/docs/users_guide/debugging.xml index 6fc1413..b84134a 100644 --- a/docs/users_guide/debugging.xml +++ b/docs/users_guide/debugging.xml @@ -476,6 +476,88 @@ style. + + + + + Formatting dumps + + formatting dumps + + + + + + + + + In error messages, expressions are printed to a + certain “depth”, with subexpressions beyond the + depth replaced by ellipses. This flag sets the + depth. Its default value is 5. + + + + + + + + + + Set the width of debugging output. Use this if your code is wrapping too much. + For example: . + + + + + + + + + + Print single alternative case expressions as though they were strict + let expressions. This is helpful when your code does a lot of unboxing. + + + + + + + + + + Suppress any unsolicited debugging output. When GHC + has been built with the DEBUG option it + occasionally emits debug output of interest to developers. + The extra output can confuse the testing framework and + cause bogus test failures, so this flag is provided to + turn it off. + + + + + + + + Suppressing unwanted information + + suppression + + Core dumps contain a large amount of information. Depending on what you are doing, not all of it will be useful. + Use these flags to suppress the parts that you are not interested in. + + + + + + + + + Suppress everything that can be suppressed, except for unique ids as this often + makes the printout ambiguous. If you just want to see the overall structure of + the code, then start here. + + @@ -483,7 +565,7 @@ - Suppress the printing of uniques in debugging output. This may make + Suppress the printing of uniques. This may make the printout ambiguous (e.g. unclear where an occurrence of 'x' is bound), but it makes the output of two compiler runs have many fewer gratuitous differences, so you can realistically apply diff. Once diff @@ -493,12 +575,13 @@ - - + + - Suppress the printing of coercions in Core dumps to make them -shorter. + Suppress extended information about identifiers where they are bound. This includes + strictness information and inliner templates. Using this flag can cut the size + of the core dump in half, due to the lack of inliner templates @@ -508,36 +591,39 @@ shorter. - Suppress the printing of module qualification prefixes in Core dumps to make them easier to read. + Suppress the printing of module qualification prefixes. + This is the Data.List in Data.List.length. - - + + - In error messages, expressions are printed to a - certain “depth”, with subexpressions beyond the - depth replaced by ellipses. This flag sets the - depth. Its default value is 5. + Suppress the printing of type signatures. - - - + + + - - Suppress any unsolicited debugging output. When GHC - has been built with the DEBUG option it - occasionally emits debug output of interest to developers. - The extra output can confuse the testing framework and - cause bogus test failures, so this flag is provided to - turn it off. - + + Suppress the printing of type applications. + + + + + + + + + + Suppress the printing of type coercions. + diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml index add2f5e..4a502b4 100644 --- a/docs/users_guide/flags.xml +++ b/docs/users_guide/flags.xml @@ -2474,32 +2474,68 @@ phase n - + + Don't output pragma info in dumps + static + - + + + + Set the depth for printing expressions in error msgs + static + - + + + + Set the width of debugging output. For example + static + - + + + + Print single alternative case expressions as strict lets. + static + - + + + + In core dumps, suppress everything that is suppressable. + static + - + + - Suppress the printing of uniques in debug output (easier to use diff. + Suppress the printing of uniques in debug output (easier to use diff) static - - - Suppress the printing of coercions in Core dumps to make them shorter. + + Suppress extended information about identifiers where they are bound static - - Suppress the printing of module qualification prefixes in Core dumps to make them easier to read. + Suppress the printing of module qualification prefixes static - - - Don't output pragma info in dumps + + Suppress type signatures static - - - Set the depth for printing expressions in error msgs + + Suppress type applications + static + - + + + + Suppress the printing of coercions in Core dumps to make them shorter static - 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/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 0f58876..b00d925 100644 --- a/ghc.mk +++ b/ghc.mk @@ -750,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 @@ -904,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 \ @@ -933,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 \ @@ -954,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) @@ -1043,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 @@ -1158,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 93199d9..da9fd8a 100644 --- a/ghc/ghc.mk +++ b/ghc/ghc.mk @@ -108,15 +108,15 @@ 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, # and the settings files they use -$(GHC_STAGE1) : | $(UNLIT) $(INPLACE_LIB)/extra-gcc-opts -$(GHC_STAGE2) : | $(UNLIT) $(INPLACE_LIB)/extra-gcc-opts -$(GHC_STAGE3) : | $(UNLIT) $(INPLACE_LIB)/extra-gcc-opts +$(GHC_STAGE1) : | $(UNLIT) $(INPLACE_LIB)/settings +$(GHC_STAGE2) : | $(UNLIT) $(INPLACE_LIB)/settings +$(GHC_STAGE3) : | $(UNLIT) $(INPLACE_LIB)/settings ifeq "$(GhcUnregisterised)" "NO" $(GHC_STAGE1) : | $(SPLIT) @@ -137,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/ghc.mk b/rts/ghc.mk index 53bb72c..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 @@ -499,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/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-prog.mk b/rules/build-prog.mk index c39f947..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 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/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 7ccc71d..5dc6a40 100755 --- a/sync-all +++ b/sync-all @@ -310,20 +310,14 @@ sub scmall { if (-d "$localpath/.git") { die "Found both _darcs and .git in $localpath"; } - else { - $scm = "darcs"; - } - } - else { - if (-d "$localpath/.git") { - $scm = "git"; - } - elsif ($tag eq "") { - die "Required repo $localpath is missing"; - } - else { - message "== $localpath repo not present; skipping"; - } + $scm = "darcs"; + } elsif (-d "$localpath/.git") { + $scm = "git"; + } elsif ($tag eq "") { + die "Required repo $localpath is missing"; + } else { + message "== $localpath repo not present; skipping"; + next; } # Work out the arguments we should give to the SCM @@ -383,6 +377,12 @@ sub scmall { } scm ($localpath, $scm, @scm_args, @args); } + elsif ($command =~ /^checkout$/) { + # Not all repos are necessarily branched, so ignore failure + $ignore_failure = 1; + scm ($localpath, $scm, "checkout", @args) + unless $scm eq "darcs"; + } elsif ($command =~ /^grep$/) { # Hack around 'git grep' failing if there are no matches $ignore_failure = 1; @@ -429,6 +429,7 @@ Supported commands: * remote add * remote rm * remote set-url [--push] + * checkout * grep * clean * reset 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